caramia 0.7.0.1 → 0.7.1.0
raw patch · 9 files changed
+129/−76 lines, 9 filesdep +test-framework-quickcheck2dep −unixdep ~basedep ~transformers
Dependencies added: test-framework-quickcheck2
Dependencies removed: unix
Dependency ranges changed: base, transformers
Files
- README.md +1/−0
- caramia.cabal +14/−6
- demos/query-objects/Main.hs +2/−1
- demos/smoke-test/Main.hs +1/−1
- src/Graphics/Caramia/Buffer.hs +6/−5
- src/Graphics/Caramia/Color.hs +46/−42
- src/Graphics/Caramia/Internal/OpenGLCApi.hs +8/−8
- src/Graphics/Caramia/Render.hs +31/−13
- tests/color/Main.hs +20/−0
README.md view
@@ -1,3 +1,4 @@+[](https://hackage.haskell.org/package/caramia) [](https://travis-ci.org/Noeda/caramia) This is a highish-level OpenGL bindings library for real-time graphics for
caramia.cabal view
@@ -1,5 +1,5 @@ name: caramia-version: 0.7.0.1+version: 0.7.1.0 synopsis: High-level OpenGL bindings homepage: https://github.com/Noeda/caramia/ license: MIT@@ -135,7 +135,7 @@ ,linear >=1.15 && <2.0 ,semigroups >=0.15 && <1.0 ,text >=0.9 && <2.0- ,transformers >=0.4 && <1.0+ ,transformers >=0.3 && <1.0 ,vector >=0.10 && <1.0 ,gl >=0.6.2 && <0.7 @@ -143,9 +143,6 @@ cpp-options: -DFIXED_OPENGL_MAJOR_VERSION=2 -DFIXED_OPENGL_MINOR_VERSION=1 - if !os(windows)- build-depends: unix >=2.7 && <3.0- hs-source-dirs: src default-language: Haskell2010 @@ -179,6 +176,17 @@ ,test-framework-hunit >=0.3.0.1 && <1.0 default-language: Haskell2010 +test-suite color+ type: exitcode-stdio-1.0+ main-is: Main.hs+ ghc-options: -Wall -fno-warn-name-shadowing -threaded -rtsopts -with-rtsopts=-N+ hs-source-dirs: tests/color+ build-depends: base, caramia+ ,linear >=1.15 && <2.0+ ,test-framework >=0.8.1 && <1.0+ ,test-framework-quickcheck2 >=0.3.0.3 && <1.0+ default-language: Haskell2010+ -- This is just a dumping ground test that does stupid things. It's used to -- check if things work at all. executable smoke-test@@ -227,7 +235,7 @@ build-depends: base, caramia ,sdl2 ==1.2.* ,text >=0.9 && <2.0- ,transformers >=0.4 && <1.0+ ,transformers >=0.3 && <1.0 ,vector >=0.10 && <1.0 else buildable: False
demos/query-objects/Main.hs view
@@ -32,6 +32,7 @@ giveContext $ do color_program <- newPipelineVF passThroughVertex2DShader coloredFragmentProgram+ mempty color_loc <- getUniformLocation "color" color_program offset_loc <- getUniformLocation "offset" color_program vao <- newVAO@@ -124,7 +125,7 @@ let byte_size = sizeOf (undefined :: Float) * V.length vec newBuffer defaultBufferCreation { size = byte_size- , initialData = Just (castPtr ptr)+ , initialData = Just $ castPtr ptr , accessHints = (Static, Draw) , accessFlags = NoAccess }
demos/smoke-test/Main.hs view
@@ -64,7 +64,7 @@ -- Compile a gazillion shaders sh1 <- newShader fragmentShaderSrc Fragment- pipeline <- newPipeline [sh1]+ pipeline <- newPipeline [sh1] mempty loc <- getUniformLocation "tutturuu" pipeline setUniform (transpose eye4 :: M44 CFloat) loc
src/Graphics/Caramia/Buffer.hs view
@@ -6,6 +6,7 @@ -- {-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-} module Graphics.Caramia.Buffer ( -- * Creation@@ -252,14 +253,14 @@ -- | Same as `bufferMap` but allows more control over mapping. ----- @ bufferMap = bufferMap2 [] @+-- @ bufferMap = bufferMap2 mempty @ bufferMap2 :: MonadIO m => S.Set MapFlag -> Int -> Int -> AccessFlags -> Buffer- -> m (Ptr ())+ -> m (Ptr a) bufferMap2 map_flags offset num_bytes access_flags buffer -- a lot of this implementation is just error checking... @@ -322,7 +323,7 @@ -> Int -- ^ How many bytes to map. -> AccessFlags -- ^ What access is allowed in the mapping. -> Buffer- -> m (Ptr ())+ -> m (Ptr a) bufferMap = bufferMap2 S.empty -- | Exception that is thrown from `bufferUnmap` when buffer corruption is detected.@@ -364,7 +365,7 @@ -> Int -> AccessFlags -> Buffer- -> (Ptr () -> m a)+ -> (Ptr b -> m a) -> m a withMapping2 map_flags offset num_bytes access_flags buffer action = mask $ \restore -> do@@ -398,7 +399,7 @@ -> Int -> AccessFlags -> Buffer- -> (Ptr () -> m a) -- ^ The pointer is valid during this action.+ -> (Ptr b -> m a) -- ^ The pointer is valid during this action. -> m a withMapping = withMapping2 S.empty
src/Graphics/Caramia/Color.hs view
@@ -1,14 +1,19 @@ -- | Color handling. -- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-} module Graphics.Caramia.Color ( -- * Types Color()+ , v4 -- * Constructing colors , rgba+ -- * Conversion to `Word8` colors.+ , floatToWord8+ , word8ToFloat -- * Lenses , rgbaL , redL@@ -26,75 +31,74 @@ import Control.Lens import Graphics.Caramia.Prelude import Foreign.Storable-import Foreign.Ptr+import Linear.V4 -- | The color data type. -- -- This data type says nothing about the color space these values are in. The -- color space depends on the usage; for example, a framebuffer with sRGB -- textures attached uses sRGB color space in these color values.-data Color = Color- { viewRed :: !Float- , viewGreen :: !Float- , viewBlue :: !Float- , viewAlpha :: !Float- }- deriving ( Eq, Ord, Show, Read, Typeable )+--+-- `Color`'s `Storable` instance is equal to `V4` `Float`'s+-- `Storable` instance, in the order \"r g b a\".+newtype Color = Color { toV4 :: (V4 Float) }+ deriving ( Eq, Ord, Show, Read, Typeable, Storable ) +v4 :: Lens' Color (V4 Float)+v4 = lens toV4 (\_ new -> Color new)++viewRed :: Color -> Float+viewRed (Color (V4 r _ _ _)) = r++viewGreen :: Color -> Float+viewGreen (Color (V4 _ g _ _)) = g++viewBlue :: Color -> Float+viewBlue (Color (V4 _ _ b _)) = b++viewAlpha :: Color -> Float+viewAlpha (Color (V4 _ _ _ a)) = a++-- | A convenience function to turn a `Float` color value to a `Word8`.+--+-- The value is clamped between 0 and 255.+floatToWord8 :: Float -> Word8+floatToWord8 f = round $ max 0 $ min 255 $ f * 255.0+{-# INLINE floatToWord8 #-}++-- | Maps a `Word8` to a `Float`, so that 255 is mapped to 1.0 and 0 is mapped+-- to 0.+word8ToFloat :: Word8 -> Float+word8ToFloat w = fromIntegral w / 255.0+{-# INLINE word8ToFloat #-}+ -- | Construct a color from rgba values. rgba :: Float -> Float -> Float -> Float -> Color-rgba = Color+rgba r g b a = Color $ V4 r g b a {-# INLINE rgba #-} -- | View rgba in a tuple. viewRgba :: Color -> (Float, Float, Float, Float)-viewRgba (Color r g b a) = (r, g, b, a)+viewRgba (Color (V4 r g b a)) = (r, g, b, a) {-# INLINE viewRgba #-} -- | Lens to all components. rgbaL :: Lens' Color (Float, Float, Float, Float)-rgbaL = lens viewRgba (\old (r, g, b, a) ->- old { viewRed = r- , viewGreen = g- , viewBlue = b- , viewAlpha = a })+rgbaL = lens viewRgba (\_ (r, g, b, a) -> Color $ V4 r g b a) -- | Lens to red component. redL :: Lens' Color Float-redL = lens viewRed (\old new -> old { viewRed = new })+redL = v4._x -- | Lens to green component. greenL :: Lens' Color Float-greenL = lens viewGreen (\old new -> old { viewGreen = new })+greenL = v4._y -- | Lens to blue component. blueL :: Lens' Color Float-blueL = lens viewBlue (\old new -> old { viewBlue = new })+blueL = v4._z -- | Lens to alpha component. alphaL :: Lens' Color Float-alphaL = lens viewAlpha (\old new -> old { viewAlpha = new })--instance Storable Color where- sizeOf _ = sizeOf (undefined :: Float) * 4- alignment _ = alignment (undefined :: Float) * 4- peek ptr = do- r <- peekElemOff cptr 0 :: IO Float- g <- peekElemOff cptr 1 :: IO Float- b <- peekElemOff cptr 2 :: IO Float- a <- peekElemOff cptr 3 :: IO Float- return $ Color r g b a- where- cptr = castPtr ptr :: Ptr Float- {-# INLINE peek #-}-- poke ptr (Color r g b a) = do- pokeElemOff cptr 0 r- pokeElemOff cptr 1 g- pokeElemOff cptr 2 b- pokeElemOff cptr 3 a- where- cptr = castPtr ptr :: Ptr Float- {-# INLINE poke #-}-+alphaL = v4._w
src/Graphics/Caramia/Internal/OpenGLCApi.hs view
@@ -234,23 +234,23 @@ mglNamedBufferStorage :: GLuint -> GLsizeiptr- -> Ptr ()+ -> Ptr a -> GLbitfield -> IO () mglNamedBufferStorage buf size ptr flags = if gl_ARB_direct_state_access- then glNamedBufferStorage buf (fromIntegral size) ptr flags- else withBoundBuffer buf $ glBufferStorage GL_ARRAY_BUFFER size ptr flags+ then glNamedBufferStorage buf (fromIntegral size) (castPtr ptr) flags+ else withBoundBuffer buf $ glBufferStorage GL_ARRAY_BUFFER size (castPtr ptr) flags mglNamedBufferData :: GLuint -> GLsizeiptr- -> Ptr ()+ -> Ptr a -> GLenum -> IO () mglNamedBufferData buf size ptr usage = if gl_ARB_direct_state_access- then glNamedBufferData buf (fromIntegral size) ptr usage- else withBoundBuffer buf $ glBufferData GL_ARRAY_BUFFER size ptr usage+ then glNamedBufferData buf (fromIntegral size) (castPtr ptr) usage+ else withBoundBuffer buf $ glBufferData GL_ARRAY_BUFFER size (castPtr ptr) usage mglProgramUniform1ui :: GLuint -> GLint -> GLuint -> IO () mglProgramUniform1ui program loc v1 =@@ -366,8 +366,8 @@ else withBoundProgram program $ glUniformMatrix3fv loc count transpose m33 mglMapNamedBufferRange :: GLuint -> GLintptr- -> GLsizeiptr -> GLbitfield -> IO (Ptr ())-mglMapNamedBufferRange buffer offset length access =+ -> GLsizeiptr -> GLbitfield -> IO (Ptr a)+mglMapNamedBufferRange buffer offset length access = fmap castPtr $ withBoundBuffer buffer $ if | openGLVersion >= OpenGLVersion 3 0 || gl_ARB_map_buffer_range
src/Graphics/Caramia/Render.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE ViewPatterns, NoImplicitPrelude, DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} module Graphics.Caramia.Render@@ -23,6 +24,8 @@ , setPrimitiveRestart , setTargetFramebuffer , setTextureBindings+ -- ** Hoisting+ , hoistDrawT -- * Specifying what to draw , DrawCommand(..) , drawCommand@@ -331,6 +334,15 @@ instance MonadTrans DrawT where lift = DrawT . lift +-- | Use to hoist the base monad in a `DrawT`.+hoistDrawT :: Monad n => (forall a. m a -> n a) -> DrawT m a -> DrawT n a+hoistDrawT changer (DrawT action) = DrawT $ do+ old_st <- get+ (result, new_st) <- lift $ changer $ runStateT action old_st+ put new_st+ return result+{-# INLINEABLE hoistDrawT #-}+ -- | Runs a drawing specification. -- -- You can think of this as running many `draw` commands with similar draw@@ -387,13 +399,15 @@ data PrimitiveRestartFuns = PrimitiveRestartFuns { prIndex :: !GLenum , prRestart :: !GLenum- , prPrimitiveRestartIndex :: !(GLuint -> IO ()) }+ , prPrimitiveRestartIndex :: !(GLuint -> IO ())+ , prEnable :: !(GLenum -> IO ())+ , prDisable :: !(GLenum -> IO ()) } withPrimitiveRestartFuns :: (Monad m, MonadIO m) => Bool -> m a -> (PrimitiveRestartFuns -> m a) -> m a withPrimitiveRestartFuns do_backup backup_action action =- if | gl_NV_primitive_restart -> action nvfuns- | openGLVersion >= OpenGLVersion 3 1 -> action o31funs+ if | openGLVersion >= OpenGLVersion 3 1 -> action o31funs+ | gl_NV_primitive_restart -> action nvfuns | do_backup -> backup_action | otherwise -> liftIO $ throwM $ NoSupport "Primitive restart requires OpenGL 3.1 or GL_NV_primitive_restart."@@ -401,10 +415,14 @@ nvfuns = PrimitiveRestartFuns GL_PRIMITIVE_RESTART_INDEX_NV GL_PRIMITIVE_RESTART_NV glPrimitiveRestartIndexNV+ glEnableClientState+ glDisableClientState o31funs = PrimitiveRestartFuns GL_PRIMITIVE_RESTART_INDEX GL_PRIMITIVE_RESTART glPrimitiveRestartIndex+ glEnable+ glDisable withPrimitiveRestart :: (MonadIO m, MonadMask m) => Maybe Word32 -> m a -> m a withPrimitiveRestart pr action =@@ -412,16 +430,16 @@ old_primitive_restart_enabled <- liftIO $ glIsEnabled prRestart old_i <- gi prIndex finally (activate funs >> action)- (do if old_primitive_restart_enabled /= 0- then glEnable prRestart- else glDisable prRestart- liftIO $ prPrimitiveRestartIndex old_i)+ (liftIO $ do if old_primitive_restart_enabled /= 0+ then prEnable prRestart+ else prDisable prRestart+ prPrimitiveRestartIndex old_i) where- activate (PrimitiveRestartFuns{..}) = case pr of- Nothing -> glDisable prRestart+ activate (PrimitiveRestartFuns{..}) = liftIO $ case pr of+ Nothing -> prDisable prRestart Just value -> do- glEnable prRestart- liftIO $ prPrimitiveRestartIndex (fromIntegral value)+ prEnable prRestart+ prPrimitiveRestartIndex (fromIntegral value) withPolygonOffset :: (MonadIO m, MonadMask m) => (Float, Float) -> m a -> m a withPolygonOffset (factor, units) action = do@@ -447,10 +465,10 @@ pr <- return . boundPrimitiveRestart =<< get liftIO $ case (pr, restart) of (Nothing, Just x) -> do- glEnable prRestart+ prEnable prRestart prPrimitiveRestartIndex (fromIntegral x) (Just _, Nothing) -> do- glDisable prRestart+ prDisable prRestart (Just y, Just x) | y /= x -> prPrimitiveRestartIndex (fromIntegral x) _ -> return ()
+ tests/color/Main.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Main ( main ) where++import Graphics.Caramia.Color+import Graphics.Caramia.Prelude+import Test.Framework+import Test.Framework.Providers.QuickCheck2++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests = [+ testProperty "floatToWord8 . word8ToFloat = id" floatwordid+ ]++floatwordid :: Word8 -> Bool+floatwordid x = floatToWord8 (word8ToFloat x) == x+