module Main where import Text.XML.Light.Input (parseXMLDoc) import qualified Text.XML.Light.Types as X import Data.Maybe (fromJust, fromMaybe) import qualified Data.Text as Txt import Control.Monad (forM_, mapM) import Graphics.Layout.CSS (CSSBox(..), finalizeCSS') import Graphics.Layout.CSS.Font (placeholderFont) import Graphics.Layout (LayoutItem, boxLayout, layoutGetBox, layoutGetChilds, layoutGetInner) import Graphics.Layout.Box (zeroBox) import qualified Graphics.Layout.Box as B import Stylist.Tree (StyleTree(..)) import Stylist (PropertyParser(..)) import Data.CSS.Syntax.Tokens (Token(..), tokenize) import Graphics.UI.GLUT import Graphics.GL.Core32 import Foreign.Ptr (castPtr, nullPtr) import Foreign.Storable (Storable(..)) import Foreign.Marshal.Array (withArrayLen, allocaArray, peekArray) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Utils (with) import Foreign.C.String (withCString) main :: IO () main = do (progname, args) <- getArgsAndInitialize source <- readFile $ case args of (filename:_) -> filename [] -> "styletree.xml" let xml = fromJust $ parseXMLDoc source let styles = xml2styles temp xml let layout = finalizeCSS' placeholderFont styles w <- createWindow progname vertexShader <- compileOGLShader vertexSource GL_VERTEX_SHADER fragmentShader <- compileOGLShader fragmentSource GL_FRAGMENT_SHADER shader <- compileOGLProgram [] [vertexShader, fragmentShader] glDetachShader shader vertexShader glDetachShader shader fragmentShader glDeleteShader vertexShader glDeleteShader fragmentShader displayCallback $= do clear [ ColorBuffer ] Size x y <- get windowSize let (display:_) = boxLayout zeroBox { B.size = B.Size (fromIntegral x) (fromIntegral y) } layout False glUseProgram shader attribScale <- withCString "windowsize" $ glGetUniformLocation shader glUniform3f attribScale (realToFrac x) (realToFrac y) 1 renderDisplay shader display flush mainLoop xml2styles :: CSSBox Nil -> X.Element -> StyleTree (CSSBox Nil) xml2styles parent el = StyleTree { style = self', children = [xml2styles self' child | X.Elem child <- X.elContent el] } where self' = foldl (applyStyle parent) temp $ X.elAttribs el applyStyle parent style (X.Attr (X.QName name _ _) val) = fromMaybe style $ longhand parent style (Txt.pack name) $ filter (/= Whitespace) $ tokenize $ Txt.pack val data Nil = Nil instance PropertyParser Nil where temp = Nil inherit _ = Nil longhand _ _ _ _ = Nothing renderDisplay :: GLuint -> LayoutItem Double Double ((Double, Double), a) -> IO () renderDisplay shader display = do let ((x, y), _) = layoutGetInner display let box = layoutGetBox display attribColour <- withCString "fill" $ glGetUniformLocation shader glUniform3f attribColour 1 0 0 drawBox x y (B.width box) (B.height box) glUniform3f attribColour 0 1 0 drawBox (x + B.left (B.margin box)) (y + B.top (B.margin box)) (B.width box - B.left (B.margin box) - B.right (B.margin box)) (B.height box - B.top (B.margin box) - B.bottom (B.margin box)) glUniform3f attribColour 0 0 1 drawBox (x + B.left (B.margin box) + B.left (B.border box)) (y + B.top (B.margin box) + B.top (B.border box)) (B.inline (B.size box) + B.left (B.padding box) + B.right (B.padding box)) (B.block (B.size box) + B.top (B.padding box) + B.bottom (B.padding box)) glUniform3f attribColour 1 1 0 drawBox (x + B.left (B.margin box) + B.left (B.border box) + B.left (B.padding box)) (y + B.top (B.margin box) + B.top (B.border box) + B.top (B.padding box)) (B.inline $ B.size box) (B.block $ B.size box) mapM (renderDisplay shader) $ layoutGetChilds display return () drawBox x y width height = do buf <- withPointer $ glGenBuffers 1 glBindBuffer GL_ARRAY_BUFFER buf glBufferData' GL_ARRAY_BUFFER [ x, y, 0, x + width, y, 0, x, y + height, 0, x + width, y, 0, x + width, y + height, 0, x, y + height, 0 ] GL_STATIC_DRAW glEnableVertexAttribArray 0 glBindBuffer GL_ARRAY_BUFFER buf glVertexAttribPointer 0 3 GL_FLOAT GL_FALSE 0 nullPtr glDrawArrays GL_TRIANGLES 0 6 glDisableVertexAttribArray 0 withPointer cb = alloca $ \ret' -> do cb ret' peek ret' glBufferData' _ [] _ = return () glBufferData' target dat usage = withArrayLen (map realToFrac dat :: [Float]) $ \len dat' -> do glBufferData target (toEnum $ len*sizeOf (head dat)) (castPtr dat') usage compileOGLShader :: String -> GLenum -> IO GLuint compileOGLShader src shType = do shader <- glCreateShader shType if shader == 0 then error "Could not create shader" else do success <-do withCString (src) $ \ptr -> with ptr $ \ptrptr -> glShaderSource shader 1 ptrptr nullPtr glCompileShader shader with (0 :: GLint) $ \ptr -> do glGetShaderiv shader GL_COMPILE_STATUS ptr peek ptr if success == GL_FALSE then do err <- do infoLog <- with (0 :: GLint) $ \ptr -> do glGetShaderiv shader GL_INFO_LOG_LENGTH ptr logsize <- peek ptr allocaArray (fromIntegral logsize) $ \logptr -> do glGetShaderInfoLog shader logsize nullPtr logptr peekArray (fromIntegral logsize) logptr return $ unlines [ "Could not compile shader:" , src , map (toEnum . fromEnum) infoLog ] error err else return shader compileOGLProgram :: [(String, Integer)] -> [GLuint] -> IO GLuint compileOGLProgram attribs shaders = do (program, success) <- do program <- glCreateProgram forM_ shaders (glAttachShader program) forM_ attribs $ \(name, loc) -> withCString name $ glBindAttribLocation program $ fromIntegral loc glLinkProgram program success <- with (0 :: GLint) $ \ptr -> do glGetProgramiv program GL_LINK_STATUS ptr peek ptr return (program, success) if success == GL_FALSE then with (0 :: GLint) $ \ptr -> do glGetProgramiv program GL_INFO_LOG_LENGTH ptr logsize <- peek ptr infoLog <- allocaArray (fromIntegral logsize) $ \logptr -> do glGetProgramInfoLog program logsize nullPtr logptr peekArray (fromIntegral logsize) logptr error $ unlines [ "Could not link program" , map (toEnum . fromEnum) infoLog ] else do forM_ shaders glDeleteShader return program vertexSource = unlines [ "#version 330 core", "layout(location = 0) in vec3 vertexPositionModelSpace;", "uniform vec3 windowsize;", "void main() {", "gl_Position.xyz = vertexPositionModelSpace/windowsize - 1;", "gl_Position.y = -gl_Position.y;", "gl_Position.w = 1.0;", "}" ] fragmentSource = unlines [ "#version 330 core", "uniform vec3 fill;", "out vec3 colour;", "void main() { colour = fill; }" ]