1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
{-# LANGUAGE OverloadedStrings #-}
module Main where
import System.Environment (getArgs)
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 SDL hiding (rotate)
import Foreign.C.Types (CInt)
import Data.Function (fix)
import Control.Monad (unless)
main :: IO ()
main = do
SDL.initializeAll
let wcfg = defaultWindow {
windowInitialSize = V2 640 480,
windowResizable = True
}
w <- createWindow "CatTrap" wcfg
renderer <- createRenderer w (-1) defaultRenderer
args <- getArgs
source <- readFile $ case args of
(filename:_) -> filename
[] -> "styletree.xml"
let xml = fromJust $ parseXMLDoc source
let styles = xml2styles temp xml
let layout = finalizeCSS' placeholderFont styles
fix $ \loop -> do
events <- fmap eventPayload <$> pollEvents
rendererDrawColor renderer $= V4 255 255 255 255
clear renderer
V2 x y <- get $ windowSize w
let (display:_) = boxLayout zeroBox {
B.size = B.Size (fromIntegral x) (fromIntegral y)
} layout False
renderDisplay renderer display
present renderer
unless (QuitEvent `elem` events) loop
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 :: Renderer -> LayoutItem Double Double ((Double, Double), Nil)
-> IO ()
renderDisplay renderer display = do
let ((x, y), _) = layoutGetInner display
let box = layoutGetBox display
rendererDrawColor renderer $= V4 255 0 0 255
drawBox renderer x y (B.width box) (B.height box)
rendererDrawColor renderer $= V4 0 255 0 255
drawBox renderer
(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))
rendererDrawColor renderer $= V4 0 0 255 255
drawBox renderer
(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))
rendererDrawColor renderer $= V4 255 255 0 255
drawBox renderer
(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 renderer) $ layoutGetChilds display
return ()
drawBox :: Renderer -> Double -> Double -> Double -> Double -> IO ()
drawBox renderer x y width height = do
fillRect renderer $ Just $ Rectangle
(P $ V2 (c x) (c y)) (V2 (c width) (c height))
c :: (Enum a, Enum b) => a -> b
c = toEnum . fromEnum