cattrap-0.2.0.0: app/Main.hs

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 deriving Eq
instance PropertyParser Nil where
    temp = Nil
    inherit _ = Nil
    longhand _ _ _ _ = Nothing

renderDisplay :: Eq a => 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; }"
  ]