SO question code

texture.hs

module Main where

import Graphics.GL
import qualified Graphics.UI.GLFW as G
import Control.Monad (unless, when)
import System.Exit
import System.IO

import qualified Codec.Picture as JP
import Data.Vector.Storable (unsafeWith)
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.Ptr

-- tiny utility functions, in the same spirit as 'maybe' or 'either'
-- makes the code a wee bit cleaner
bool :: Bool -> a -> a -> a
bool b falseRes trueRes = if b then trueRes else falseRes

unless' :: Monad m => m Bool -> m () -> m ()
unless' action falseAction = do
    b <- action
    unless b falseAction

maybe' :: Maybe a -> b -> (a -> b) -> b
maybe' m nothingRes f = case m of
    Nothing -> nothingRes
    Just x  -> f x

errorCallback :: G.ErrorCallback
errorCallback err description = hPutStrLn stderr description


keyCallback :: G.KeyCallback
keyCallback window key scancode action mods = when (key == G.Key'Escape && action == G.KeyState'Pressed) $
  G.setWindowShouldClose window True

load :: IO ()
load = do
    image <- JP.readImage "image.png"
    case image of
        (Left err) -> do print err
                         exitWith (ExitFailure 1)
        (Right imgData) -> do 
            a <- malloc
            glGenTextures 1 a
            texId <- peek a
            free a
            loadImgIntoTexture texId imgData

loadImgIntoTexture texId (JP.ImageRGBA8 (JP.Image width height dat)) = do
    glBindTexture GL_TEXTURE_2D texId
    unsafeWith dat $ glTexImage2D GL_TEXTURE_2D 0 GL_RGBA (fromIntegral width) (fromIntegral height) 0 GL_RGBA GL_UNSIGNED_BYTE . castPtr
    --p <- mallocBytes $ (fromIntegral width) * (fromIntegral height) * 4
    --glTexImage2D GL_TEXTURE_2D 0 GL_RGBA (fromIntegral width) (fromIntegral height) 0 GL_RGBA GL_UNSIGNED_BYTE (castPtr p)
    print "everything ok"

main :: IO ()
main = do
  G.setErrorCallback (Just errorCallback)
  successfulInit <- G.init
  -- if init failed, we exit the program
  bool successfulInit exitFailure $ do
      G.windowHint (G.WindowHint'ContextVersionMajor 4)
      G.windowHint (G.WindowHint'ContextVersionMinor 4)
      G.windowHint (G.WindowHint'OpenGLForwardCompat True)
      G.windowHint (G.WindowHint'OpenGLProfile G.OpenGLProfile'Core)
      G.windowHint (G.WindowHint'OpenGLDebugContext True)

      mw <- G.createWindow 640 480 "Simple example, haskell style" Nothing Nothing
      maybe' mw (G.terminate >> exitFailure) $ \window -> do
          G.makeContextCurrent mw
          G.setKeyCallback window (Just keyCallback)

          load

          mainLoop window
          G.destroyWindow window
          G.terminate
          exitSuccess
          
mainLoop :: G.Window -> IO ()
mainLoop w = unless' (G.windowShouldClose w) $ do
    (width, height) <- G.getFramebufferSize w
    let ratio = fromIntegral width / fromIntegral height
    
    --glViewport (Position 0 0, Size (fromIntegral width) (fromIntegral height))
    glClearColor 0.5 0.0 0.0 1.0
    glClear GL_COLOR_BUFFER_BIT
    
        
    G.swapBuffers w
    G.pollEvents
    mainLoop w