From 10e61b666d684f0691b382eaa8870eafa99936aa Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Mon, 5 Jun 2023 16:28:02 +1200
Subject: [PATCH] Add test script!

---
 Mondrian.cabal                             |  3 +-
 app/Main.hs                                | 68 +++++++++++++++++++++-
 lib/Graphics/Rendering/Rect.hs             | 21 ++++++-
 lib/Graphics/Rendering/Rect/Backgrounds.hs |  2 +-
 lib/Graphics/Rendering/Rect/Types.hs       |  4 +-
 5 files changed, 91 insertions(+), 7 deletions(-)

diff --git a/Mondrian.cabal b/Mondrian.cabal
index 8471c3e..f3a15f4 100644
--- a/Mondrian.cabal
+++ b/Mondrian.cabal
@@ -35,7 +35,8 @@ executable Mondrian
   main-is:             Main.hs
   -- other-modules:
   -- other-extensions:
-  build-depends:       base >=4.13 && <4.14, Mondrian
+  build-depends:       base >=4.13 && <4.14, Mondrian, sdl2 >= 2.5.4, gl, linear,
+                        stylist-traits, text, css-syntax
   hs-source-dirs:      app
   default-language:    Haskell2010
 
diff --git a/app/Main.hs b/app/Main.hs
index 76e4cc6..7239a10 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,5 +1,71 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Main where
 
+import Graphics.Rendering.Rect
+import Stylist.Parse (parseProperties')
+import Stylist (PropertyParser(..))
+import Data.Text (pack, unpack)
+import Data.CSS.Syntax.Tokens (tokenize, serialize)
+
+import SDL hiding (trace)
+import Graphics.GL.Core32
+import System.Environment (getArgs)
+import Linear.Projection (ortho)
+
+import Data.Function (fix)
+import Control.Monad (unless)
+import Control.Monad.IO.Class (MonadIO (..))
+
+import Debug.Trace (trace) -- To warn about invalid args
+
+parseStyle syn
+    | (ret, []) <- parseProperties' toks = apply ret
+    | (ret, tail) <- parseProperties' toks =
+        trace ("Extraneous chars: " ++ unpack (serialize tail)) $ apply ret
+  where
+    toks = tokenize $ pack syn
+    apply ((key, val):props)
+        | Just self' <- longhand self self key val = self'
+        | otherwise = apply (shorthand self key val ++ props)
+      where self = apply props
+    apply [] = temp
+
+orthoProjection (V2 ww wh) =
+  let (hw,hh) = (fromIntegral ww, fromIntegral wh)
+  in ortho 0 hw hh 0 0 1
+
 main :: IO ()
 main = do
-  putStrLn "Hello, Haskell!"
+    SDL.initializeAll
+    args <- getArgs
+    let style :: RectStyle
+        style = case args of
+            [] -> trace "Using blank styles, should see blank screen!" temp
+            [arg] -> parseStyle arg
+            (arg:_) -> trace "Extraneous commandline args!" $ parseStyle arg
+
+    let openGL = defaultOpenGL { glProfile = Core Debug 3 3 }
+        wcfg = defaultWindow {
+            windowInitialSize = V2 640 480,
+            windowGraphicsContext = OpenGLContext openGL,
+            windowResizable = True
+          }
+    w <- createWindow "Mondrian" wcfg
+    _ <- glCreateContext w
+
+    render <- renderRects
+    fix $ \loop -> do
+        events <- fmap eventPayload <$> pollEvents
+        liftIO $ glClearColor 1 1 1 1
+        liftIO $ glClear GL_COLOR_BUFFER_BIT
+
+        sz@(V2 dw dh) <- liftIO $ glGetDrawableSize w
+        liftIO $ glViewport 0 0 (fromIntegral dw) (fromIntegral dh)
+
+        let rect = Rect 0 0 (fromIntegral dw) (fromIntegral dh)
+            rects = Rects (shrink1 rect 15) (shrink1 rect 10) (shrink1 rect 5) rect
+
+        render style rects $ orthoProjection sz
+
+        liftIO $ glSwapWindow w
+        unless (QuitEvent `elem` events) loop
diff --git a/lib/Graphics/Rendering/Rect.hs b/lib/Graphics/Rendering/Rect.hs
index c38e20d..93058e6 100644
--- a/lib/Graphics/Rendering/Rect.hs
+++ b/lib/Graphics/Rendering/Rect.hs
@@ -1,6 +1,23 @@
-module Graphics.Rendering.Rect(Rect(..), Rects(..),
+module Graphics.Rendering.Rect(Rect(..), Rects(..), shrink, shrink1, renderRects,
     RectStyle(..), colour, Backgrounds(..)) where
 
 import Graphics.Rendering.Rect.CSS
-import Graphics.Rendering.Rect.CSS.Background
+import Graphics.Rendering.Rect.Backgrounds
 import Graphics.Rendering.Rect.Types
+
+import Linear (M44)
+import Control.Monad.IO.Class (MonadIO)
+
+shrink :: Rect -> Float -> Float -> Float -> Float -> Rect
+shrink self dLeft dTop dRight dBottom =
+    Rect (left self - dLeft) (top self - dTop)
+         (right self - dRight) (bottom self - dBottom)
+shrink1 :: Rect -> Float -> Rect
+shrink1 self d = shrink self d d d d
+
+renderRects :: (MonadIO m, MonadIO n) =>
+        n (RectStyle -> Rects -> M44 Float -> m ())
+renderRects = do
+    bg <- renderBackgrounds
+    return $ \style rects mat -> do
+        bg (backgrounds style) rects mat
diff --git a/lib/Graphics/Rendering/Rect/Backgrounds.hs b/lib/Graphics/Rendering/Rect/Backgrounds.hs
index 6408e8d..18cf113 100644
--- a/lib/Graphics/Rendering/Rect/Backgrounds.hs
+++ b/lib/Graphics/Rendering/Rect/Backgrounds.hs
@@ -7,7 +7,7 @@ import Linear (M44)
 import Control.Monad.IO.Class (MonadIO(..))
 
 baseFragmentShader = B8.pack $ unlines [
-    "#version 330 core;",
+    "#version 330 core",
     "out vec4 fcolour;",
     "in vec4 colour;",
     "void main() { fcolour = colour; }"
diff --git a/lib/Graphics/Rendering/Rect/Types.hs b/lib/Graphics/Rendering/Rect/Types.hs
index 7a0218b..646f550 100644
--- a/lib/Graphics/Rendering/Rect/Types.hs
+++ b/lib/Graphics/Rendering/Rect/Types.hs
@@ -36,10 +36,10 @@ data Rects = Rects {
 } deriving (Read, Show, Eq, Ord)
 
 vertexShader = B8.pack $ unlines [
-    "#version 330 core;",
+    "#version 330 core",
     "uniform mat4 transform;",
     "in vec2 pos;",
-    "void main() { gl_Position = pos * transform; }"
+    "void main() { gl_Position = vec4(pos, 0, 1) * transform; }"
   ]
 
 type Uniform m = GLuint -> GLint -> m ()
-- 
2.30.2