SFML-control (empty) → 0.2.0.0
raw patch · 9 files changed
+577/−0 lines, 9 filesdep +SFMLdep +basedep +mtlsetup-changed
Dependencies added: SFML, base, mtl, template-haskell
Files
- LICENSE +0/−0
- README.md +70/−0
- SFML-control.cabal +30/−0
- Setup.hs +2/−0
- src/Control/Monad/SFML.hs +28/−0
- src/Control/Monad/SFML/Conversions.hs +326/−0
- src/Control/Monad/SFML/Types.hs +12/−0
- src/Control/Monad/SFML/Types/Internal.hs +20/−0
- src/Control/Monad/SFML/Types/TH.hs +89/−0
+ LICENSE view
+ README.md view
@@ -0,0 +1,70 @@+SFML-control+============++This library expose a SFML monad which deliver a higher level of abstraction+over the low level bindings.++# What do you mean by higher level?+It exposes a `SFML` monad you must use and eventually run to go back into `IO`.+In doing that, the `SFML` monad runs all the destructors for you. This means you+don't have to worry about explicit deallocation of the underlying C resources.++# How the bindings are achieved?+To scrap as much boilerplate as possible, TH has been used. In fact, thanks to+the TH machinery, the whole [SFML](https://github.com/SFML-haskell/SFML) functions has been lifted appropriately here:++[Conversions](https://github.com/SFML-haskell/SFML-control/blob/master/src/Control/Monad/SFML/Conversions.hs)++# Example+This is a 1:1 translation of [this](https://github.com/SFML-haskell/SFML/blob/master/demos/hello/main.hs) example:++``` haskell+module Main where++import Control.Monad.SFML+import qualified SFML.Graphics as G+import qualified SFML.Window as W+import SFML.Graphics.Color++import Paths_SFMLExamples++main :: IO ()+main = runSFML $ do+ let ctxSettings = Just $ W.ContextSettings 24 8 0 1 2+ wnd <- createRenderWindow (W.VideoMode 640 480 32)+ "SFML-Control Demo" [W.SFDefaultStyle] ctxSettings+ logoPath <- liftIO $ getDataFileName "Haskell-Logo.png"+ fontPath <- liftIO $ getDataFileName "Vera.ttf"+ musicPath <- liftIO $ getDataFileName "DST-BreakOut.ogg"+ tex <- textureFromFile logoPath Nothing+ spr <- createSprite+ fnt <- fontFromFile fontPath+ txt <- createText+ setTextString txt "Haskell-Control\nhandles memory\nfor you"+ setTextFont txt fnt+ setTextCharacterSize txt 20+ setTextColor txt blue+ msc <- musicFromFile musicPath+ play msc+ setTexture spr tex True+ loop wnd spr txt+++loop :: G.RenderWindow -> G.Sprite -> G.Text -> SFML ()+loop wnd spr txt = do+ drawSprite wnd spr Nothing+ drawText wnd txt $ Just (G.renderStates { G.transform = G.translation 460 40 })+ display wnd+ evt <- waitEvent wnd+ case evt of+ Nothing -> return ()+ Just W.SFEvtClosed -> return ()+ _ -> loop wnd spr txt+```++As you can see it's almost a 1:1 translation, you just need to run the monad+and get rid of explicit `destroy` !++# Why two libraries?+We decided that the user shouldn't pay the extra burder of a `SFML` monad if all he+wants is a low level SFML binding.
+ SFML-control.cabal view
@@ -0,0 +1,30 @@+name: SFML-control+version: 0.2.0.0+synopsis: Higher level library on top of SFML+license: MIT+license-file: LICENSE+author: Alfredo Di Napoli+maintainer: alfredo.dinapoli@gmail.com+category: Graphics+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ exposed-modules:+ Control.Monad.SFML+ Control.Monad.SFML.Types+ Control.Monad.SFML.Types.TH+ other-modules:+ Control.Monad.SFML.Types.Internal+ Control.Monad.SFML.Conversions+ -- other-extensions:+ build-depends:+ base >= 4.6 && < 5,+ mtl >= 2.0.0.0,+ SFML >= 0.2.0.0,+ template-haskell -any+ hs-source-dirs:+ src+ default-language:+ Haskell2010
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Control/Monad/SFML.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Control.Monad.SFML+ ( module Control.Monad.SFML.Types+ , module Control.Monad.SFML.Conversions+ , liftIO+ ) where+++import SFML.System.Vector2+import qualified SFML.Graphics as G++import Control.Monad.State.Strict hiding (lift)+++import Control.Monad.SFML.Types.Internal+import Control.Monad.SFML.Types+import Control.Monad.SFML.Conversions+++--------------------------------------------------------------------------------+drawRectangleOfSize :: Vec2f -> SFML G.RectangleShape+drawRectangleOfSize size = SFML $ do+ shp <- liftIO . G.err $ G.createRectangleShape+ liftIO $ G.setSize shp size+ modify $ \s -> G.destroy shp : s+ return shp
+ src/Control/Monad/SFML/Conversions.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Control.Monad.SFML.Conversions where+++import Control.Monad.SFML.Types.TH+import qualified SFML.Graphics as G+import qualified SFML.Audio as A+import qualified SFML.System as S+import qualified SFML.Window as W+import Data.Maybe++-- | Run the given IO action and throw an error if it fails.+mb :: IO (Maybe a) -> IO a+mb = (maybe (error "Nothing found.") return =<<)+++-- Audio / Listener.hs+$(lift 'A.setGlobalVolume)+$(lift 'A.getGlobalVolume)+$(lift 'A.setListenerPosition)+$(lift 'A.getListenerPosition)+$(lift 'A.setListenerDirection)+$(lift 'A.getListenerDirection)++-- Audio / Music.hs+$(liftWithDestroy 'G.err 'A.musicFromFile)+$(liftWithDestroy 'G.err 'A.musicFromMemory)+$(liftWithDestroy 'G.err 'A.musicFromStream)+$(lift 'A.setLoop)+$(lift 'A.getLoop)+$(lift 'A.getDuration)+$(lift 'A.play)+$(lift 'A.pause)+$(lift 'A.stop)+$(lift 'A.getChannelCount)+$(lift 'A.getSampleRate)+$(lift 'A.getStatus)+$(lift 'A.getPlayingOffset)+$(lift 'A.setPitch)+$(lift 'A.setVolume)+$(lift 'A.setPosition)+$(lift 'A.setRelativeToListener)+$(lift 'A.setMinDistance)+$(lift 'A.setAttenuation)+$(lift 'A.setPlayingOffset)+$(lift 'A.getPitch)+$(lift 'A.getVolume)+$(lift 'A.getPosition)+$(lift 'A.isRelativeToListener)+$(lift 'A.getMinDistance)+$(lift 'A.getAttenuation)++-- Audio / Sound.hs+$(liftWithDestroy 'id 'A.createSound)+$(lift 'A.copySound)+$(lift 'A.setSoundBuffer)+$(lift 'A.getSoundBuffer)++-- Audio / SoundBuffer.hs+$(liftWithDestroy 'G.err 'A.soundBufferFromFile)+$(liftWithDestroy 'G.err 'A.soundBufferFromMemory)+$(liftWithDestroy 'G.err 'A.soundBufferFromStream)+$(liftWithDestroy 'mb 'A.soundBufferFromSamples)+$(lift 'A.copySoundBuffer)+$(lift 'A.saveSoundBufferToFile)+$(lift 'A.getSamples)+$(lift 'A.getSampleCount)++-- Audio / SoundBufferRecorder.hs+$(liftWithDestroy 'G.err 'A.createSoundBufferRecorder)+$(lift 'A.startRecording)+$(lift 'A.stopRecording)++-- Audio / SoundRecorder.hs+$(liftWithDestroy 'G.err 'A.createSoundRecorder)+$(lift 'A.isSoundRecorderAvailable)++-- Audio / SoundStream.hs+$(liftWithDestroy 'id 'A.createSoundStream)++-- Graphics / CircleShape.hs+$(liftWithDestroy 'G.err 'G.createCircleShape)+$(lift 'G.copy)+$(lift 'G.setRotation)+$(lift 'G.setScale)+$(lift 'G.setOrigin)+$(lift 'G.getRotation)+$(lift 'G.getScale)+$(lift 'G.getOrigin)+$(lift 'G.move)+$(lift 'G.rotate)+$(lift 'G.scale)+$(lift 'G.getTransform)+$(lift 'G.getInverseTransform)+$(lift 'G.setTexture)+$(lift 'G.setTextureRect)+$(lift 'G.getTexture)+$(lift 'G.getTextureRect)+$(lift 'G.setFillColor)+$(lift 'G.setOutlineColor)+$(lift 'G.setOutlineThickness)+$(lift 'G.getFillColor)+$(lift 'G.getOutlineColor)+$(lift 'G.getOutlineThickness)+$(lift 'G.getPointCount)+$(lift 'G.getPoint)+$(lift 'G.setRadius)+$(lift 'G.getRadius)+$(lift 'G.setPointCount)+$(lift 'G.getLocalBounds)+$(lift 'G.getGlobalBounds)++-- Graphics / ConvexShape.hs+$(liftWithDestroy 'G.err 'G.createConvexShape)+$(lift 'G.setPoint)++-- Graphics / Font.hs+$(liftWithDestroy 'G.err 'G.fontFromFile)+$(liftWithDestroy 'G.err 'G.fontFromMemory)+$(liftWithDestroy 'G.err 'G.fontFromStream)+$(lift 'G.getGlyph)+$(lift 'G.getKerning)+$(lift 'G.getLineSpacing)+$(lift 'G.getFontTexture)++-- Graphics / Image.hs+$(liftWithDestroy 'G.err 'G.createImage)+$(liftWithDestroy 'id 'G.imageFromColor)+$(liftWithDestroy 'id 'G.imageFromPixels)+$(liftWithDestroy 'mb 'G.imageFromFile)+$(liftWithDestroy 'mb 'G.imageFromMemory)+$(liftWithDestroy 'mb 'G.imageFromStream)+$(lift 'G.destroy)+$(lift 'G.saveImage)+$(lift 'G.imageSize)+$(lift 'G.createMaskFromColor)+$(lift 'G.copyImage')+$(lift 'G.setPixel)+$(lift 'G.getPixel)+$(lift 'G.getPixels)+$(lift 'G.flipHorizontally)+$(lift 'G.flipVertically)++-- Graphics / RectangleShape.hs+$(liftWithDestroy 'G.err 'G.createRectangleShape)+$(lift 'G.setSize)+$(lift 'G.getSize)++-- Graphics / RenderTexture.hs+$(liftWithDestroy 'G.err 'G.createRenderTexture)+$(lift 'G.getTextureSize)+$(lift 'G.setActive)+$(lift 'G.clear)+$(lift 'G.setView)+$(lift 'G.getView)+$(lift 'G.getDefaultView)+$(lift 'G.getViewport)+$(lift 'G.mapPixelToCoords)+$(lift 'G.drawSprite)+$(lift 'G.drawText)+$(lift 'G.drawShape)+$(lift 'G.drawCircle)+$(lift 'G.drawConvexShape)+$(lift 'G.drawRectangle)+$(lift 'G.drawVertexArray)+$(lift 'G.drawPrimitives)+$(lift 'G.drawPrimitives')+$(lift 'G.pushGLStates)+$(lift 'G.popGLStates)+$(lift 'G.resetGLStates)+$(lift 'G.getRenderTexture)+$(lift 'G.setSmooth)+$(lift 'G.isSmooth)++-- Graphics / RenderWindow.hs+$(liftWithDestroy 'id 'G.createRenderWindow)+$(liftWithDestroy 'id 'G.renderWindowFromHandle)+$(lift 'G.close)+$(lift 'G.isWindowOpen)+$(lift 'G.getWindowSettings)+$(lift 'G.pollEvent)+$(lift 'G.waitEvent)+$(lift 'G.getWindowPosition)+$(lift 'G.setWindowPosition)+$(lift 'G.getWindowSize)+$(lift 'G.setWindowSize)+$(lift 'G.setWindowTitle)+$(lift' 'G.setWindowIcon 4)+$(lift 'G.setWindowVisible)+$(lift 'G.setMouseVisible)+$(lift 'G.setVSync)+$(lift 'G.setKeyRepeat)+$(lift 'G.setWindowActive)+$(lift 'G.display)+$(lift 'G.setFramerateLimit)+$(lift 'G.setJoystickThreshold)+$(lift 'G.getSystemHandle)+$(lift 'G.clearRenderWindow)+$(lift 'G.captureRenderWindow)+$(lift 'G.getMousePosition)+$(lift 'G.setMousePosition)++-- Graphics / Shader.hs+$(liftWithDestroy 'G.err 'G.shaderFromFile)+$(liftWithDestroy 'G.err 'G.shaderFromMemory)+$(liftWithDestroy 'G.err 'G.shaderFromStream)+$(lift 'G.setFloatParameter)+$(lift 'G.setFloat2Parameter)+$(lift 'G.setFloat3Parameter)+$(lift 'G.setFloat4Parameter)+$(lift 'G.setVector2Parameter)+$(lift 'G.setVector3Parameter)+$(lift 'G.setColorParameter)+$(lift 'G.setTransformParameter)+$(lift 'G.setTextureParameter)+$(lift 'G.setCurrentTextureParameter)+$(lift 'G.bind)+$(lift 'G.isShaderAvailable)++-- Graphics / Shape.hs+$(liftWithDestroy 'id 'G.createShape)+$(lift 'G.updateShape)++-- Graphics / Sprite.hs+$(liftWithDestroy 'G.err 'G.createSprite)+$(lift 'G.setColor)+$(lift 'G.getColor)++-- Graphics / Text.hs+$(liftWithDestroy 'G.err 'G.createText)+$(lift 'G.setTextString)+$(lift 'G.setTextStringU)+$(lift 'G.setTextFont)+$(lift 'G.setTextCharacterSize)+$(lift 'G.setTextStyle)+$(lift 'G.setTextColor)+$(lift 'G.getTextString)+$(lift 'G.getTextUnicodeString)+$(lift 'G.getTextFont)+$(lift 'G.getTextCharacterSize)+$(lift 'G.getTextStyle)+$(lift 'G.getTextColor)+$(lift 'G.findTextCharacterPos)+$(lift 'G.getTextLocalBounds)+$(lift 'G.getTextGlobalBounds)++-- Graphics / Texture.hs+$(liftWithDestroy 'G.err 'G.createTexture)+$(liftWithDestroy 'G.err 'G.textureFromFile)+$(liftWithDestroy 'G.err 'G.textureFromMemory)+$(liftWithDestroy 'G.err 'G.textureFromStream)+$(liftWithDestroy 'G.err 'G.textureFromImage)+$(lift 'G.textureSize)+$(lift 'G.copyTextureToImage)+$(lift 'G.updateTextureFromPixels)+$(lift 'G.updateTextureFromImage)+$(lift 'G.updateTextureFromWindow)+$(lift 'G.updateTextureFromRenderWindow)+$(lift 'G.setRepeated)+$(lift 'G.isRepeated)++-- Graphics / VertexArray.hs+$(liftWithDestroy 'id 'G.createVA)+$(lift 'G.getVertexCount)+$(lift 'G.getVertex)+$(lift 'G.clearVA)+$(lift 'G.resizeVA)+$(lift 'G.appendVA)+$(lift 'G.setPrimitiveType)+$(lift 'G.getPrimitiveType)+$(lift 'G.getVABounds)++-- Graphics / View.hs+$(liftWithDestroy 'id 'G.createView)+$(lift 'G.viewFromRect)+$(lift 'G.copyView)+$(lift 'G.setViewCenter)+$(lift 'G.setViewSize)+$(lift 'G.setViewRotation)+$(lift 'G.setViewport)+$(lift 'G.resetView)+$(lift 'G.getViewCenter)+$(lift 'G.getViewSize)+$(lift 'G.getViewRotation)+$(lift 'G.getViewViewport)+$(lift 'G.moveView)+$(lift 'G.rotateView)+$(lift 'G.zoomView)++-- System / Clock.hs+$(liftWithDestroy 'id 'S.createClock)+$(lift 'S.getElapsedTime)+$(lift 'S.restartClock)++-- System / Sleep.hsc+$(lift 'S.sfSleep)+++-- Window / Context.hsc+$(liftWithDestroy 'id 'W.createContext)+$(lift 'W.setActiveContext)++-- Window / Joystick.hs+$(lift 'W.isJoystickConnected)+$(lift 'W.getButtonCount)+$(lift 'W.hasAxis)+$(lift 'W.isJoystickButtonPressed)+$(lift 'W.getAxisPosition)+$(lift 'W.updateJoystick)++-- Window / Keyboard.hs+$(lift 'W.isKeyPressed)++-- Window / Mouse.hs+$(lift 'W.isMouseButtonPressed)++-- Window / VideoMode.hs+$(lift 'W.getDesktopMode)+$(lift 'W.getFullscreenModes)+$(lift 'W.isValid)++-- Window / Window.hsc+$(liftWithDestroy 'id 'W.createWindow)+$(liftWithDestroy 'id 'W.windowFromHandle)
+ src/Control/Monad/SFML/Types.hs view
@@ -0,0 +1,12 @@+module Control.Monad.SFML.Types+ ( SFML+ , runSFML ) where++import Control.Monad.State.Strict+import Control.Monad.SFML.Types.Internal+++--------------------------------------------------------------------------------+-- | Run the SFML monad, calling all the destructors appropriately.+runSFML :: SFML a -> IO ()+runSFML (SFML m) = join . fmap sequence_ . flip execStateT [] $ m
+ src/Control/Monad/SFML/Types/Internal.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Control.Monad.SFML.Types.Internal+ ( SFML(..)+ , SFMLState) where++import Control.Monad.State.Strict+import Control.Applicative+++--------------------------------------------------------------------------------+type DestroyAction = IO ()+++--------------------------------------------------------------------------------+type SFMLState = [DestroyAction]+++--------------------------------------------------------------------------------+newtype SFML a = SFML { unSFML :: StateT SFMLState IO a }+ deriving (Functor, Applicative, Monad, MonadIO)
+ src/Control/Monad/SFML/Types/TH.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+module Control.Monad.SFML.Types.TH+ ( lift+ , lift'+ , liftWithDestroy+ ) where++import Language.Haskell.TH+import Data.Char+import Control.Monad.State.Strict hiding (lift)+import Control.Monad.SFML.Types.Internal+import qualified SFML.Graphics as G+++{-- This module offer abstractions to easily convert+ original low-level Haskell functions into the SFML monad+--}++--------------------------------------------------------------------------------+-- | Generates a new function, lifted inside the SFML monad.+lift :: Name -> Q [Dec]+lift adapteeName = do+ argsNum <- extractArgNum adapteeName+ lift' adapteeName argsNum+++lift' :: Name -> Int -> Q [Dec]+lift' adapteeName argNum = do+ let args = mkArgs argNum+ adapteeFn <- varE adapteeName+ let wrapper = mkApply adapteeFn (map VarE args)+ fnBody <- [| SFML $ liftIO $ $(return wrapper) |]+ generateWrapper adapteeName args fnBody+++--------------------------------------------------------------------------------+generateWrapper :: Name -> [Name] -> Exp -> Q [Dec]+generateWrapper adapteeName args fnBody = do+ adapterName <- newName $ nameBase adapteeName+ adapteeFn <- varE adapteeName+ let wrapper = mkApply adapteeFn (map VarE args)+ return [FunD adapterName [Clause (map VarP args) (NormalB fnBody) []]]+++--------------------------------------------------------------------------------+liftWithDestroy :: Name -> Name -> Q [Dec]+liftWithDestroy modifier adapteeName = do+ argsNum <- extractArgNum adapteeName+ let args = mkArgs argsNum+ adapteeFn <- varE adapteeName+ let wrapper = mkApply adapteeFn (map VarE args)+ fnBody <- [| SFML $ do+ res <- liftIO $ $(varE modifier) $ $(return wrapper)+ modify $ \s -> G.destroy res : s+ return res |]+ generateWrapper adapteeName args fnBody+++--------------------------------------------------------------------------------+mkArgs :: Int -> [Name]+mkArgs n = map (mkName . (:[])) . take n $ ['a' .. 'z']+++--------------------------------------------------------------------------------+extractArgNum :: Name -> Q Int+extractArgNum fname = do+ info <- reify fname+ case info of+ (VarI _ (ForallT _ _ t) _ _) -> return . countArgs $ t+ (VarI _ t _ _) -> return . countArgs $ t+ (ClassOpI _ (ForallT _ _ t) _ _) -> return . countArgs $ t+ e -> error $ show e ++ " is not a function."++ where+ countArgs (AppT (AppT ArrowT _) ts) = 1 + countArgs ts+ countArgs _ = 0+++--------------------------------------------------------------------------------+-- Given f and its args (e.g. x y z) builds ((f x) y) z)+mkApply :: Exp -> [Exp] -> Exp+mkApply fn [] = fn+mkApply fn (x:xs) = foldl AppE (AppE fn x) xs+++--------------------------------------------------------------------------------+capitalize [] = []+capitalize (x:xs) = toUpper x : xs