From d379817e6fa92b7763f325e3a9497936d5bfd7ce Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 11 Mar 2023 16:55:31 +1300 Subject: [PATCH] Finish implementing preprocessing/CSS parsing & integrating everything with test script. --- Graphics/Layout.hs | 4 + Graphics/Layout/CSS.hs | 110 +++++++++++++-- Graphics/Layout/CSS/Internal.hs | 239 ++++++++++++++++++++++++++++---- Graphics/Layout/Grid/CSS.hs | 21 ++- app/Main.hs | 212 +++++++++++++++++++++++++++- cattrap.cabal | 4 +- 6 files changed, 538 insertions(+), 52 deletions(-) diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs index 7e5609a..44b1d2e 100644 --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -19,6 +19,10 @@ layoutGetBox (LayoutGrid _ self _) = zero { B.max = containerMax self } setCellBox' (child, cell) = cell { gridItemBox = layoutGetBox child } +layoutGetChilds (LayoutFlow _ _ ret) = ret +layoutGetChilds (LayoutGrid _ _ ret) = map snd ret +layoutGetInner (LayoutFlow ret _ _) = ret +layoutGetInner (LayoutGrid ret _ _) = ret boxMinWidth :: Zero y => Maybe Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x) boxMinWidth parent (LayoutFlow val self childs) = (min', LayoutFlow val self' childs') diff --git a/Graphics/Layout/CSS.hs b/Graphics/Layout/CSS.hs index d63e36d..b0215d9 100644 --- a/Graphics/Layout/CSS.hs +++ b/Graphics/Layout/CSS.hs @@ -4,6 +4,7 @@ module Graphics.Layout.CSS where import Data.CSS.Syntax.Tokens (Token(..)) import qualified Data.Text as Txt import Stylist (PropertyParser(..), TrivialPropertyParser) +import Stylist.Tree (StyleTree(..)) import Graphics.Layout.Box as B import Graphics.Layout @@ -16,16 +17,20 @@ data CSSBox a = CSSBox { boxSizing :: BoxSizing, cssBox :: PaddedBox Unitted Unitted, -- Some units need to be resolved per font. calc()? font :: Pattern, + font' :: CSSFont, inner :: a, gridStyles :: CSSGrid, - cellStyles :: CSSCell + cellStyles :: CSSCell, + captionBelow :: Bool } data BoxSizing = BorderBox | ContentBox noborder = Border (0,"px") (0,"px") (0,"px") (0,"px") data Display = Block | Grid | Table | TableRow | TableHeaderGroup | TableRowGroup | TableFooterGroup | TableCell | - TableColumn | TableColumnGroup | TableCaption + TableColumn | TableColumnGroup | TableCaption deriving Eq +rowContainer CSSBox { display = d } = + d `elem` [Table, TableHeaderGroup, TableRowGroup, TableFooterGroup] instance PropertyParser a => PropertyParser (CSSBox a) where temp = CSSBox { @@ -40,18 +45,22 @@ instance PropertyParser a => PropertyParser (CSSBox a) where margin = noborder }, font = temp, + font' = temp, inner = temp, gridStyles = temp, - cellStyles = temp + cellStyles = temp, + captionBelow = False } inherit parent = CSSBox { boxSizing = boxSizing parent, display = Block, cssBox = cssBox (temp :: CSSBox TrivialPropertyParser), font = inherit $ font parent, + font' = inherit $ font' parent, inner = inherit $ inner parent, gridStyles = inherit $ gridStyles parent, - cellStyles = inherit $ cellStyles parent + cellStyles = inherit $ cellStyles parent, + captionBelow = captionBelow parent } longhand _ self "box-sizing" [Ident "content-box"] = Just self {boxSizing = ContentBox} @@ -99,25 +108,100 @@ instance PropertyParser a => PropertyParser (CSSBox a) where longhand _ self "display" [Ident "block"] = Just self { display = Block } longhand _ self "display" [Ident "grid"] = Just self { display = Grid } longhand _ self "display" [Ident "table"] = Just self { display = Table } - longhand _ self "display" [Ident "table-row-group"] = Just self {display=TableRowGroup} - longhand _ self "display" [Ident "table-header-group"] = + longhand CSSBox { display = Table } self "display" [Ident "table-row-group"] = + Just self { display=TableRowGroup } + longhand CSSBox { display = Table } self "display" [Ident "table-header-group"] = Just self { display = TableHeaderGroup } - longhand _ self "display" [Ident "table-footer-group"] = + longhand CSSBox { display = Table } self "display" [Ident "table-footer-group"] = Just self { display = TableFooterGroup } - longhand _ self "display" [Ident "table-row"] = Just self {display = TableRow} - longhand _ self "display" [Ident "table-cell"] = Just self {display = TableCell} - longhand _ self "display" [Ident "table-column-group"] = + longhand parent self "display" [Ident "table-row"] | rowContainer parent = + Just self { display = TableRow } + longhand CSSBox { display = TableRow } self "display" [Ident "table-cell"] = + Just self { display = TableCell } + longhand CSSBox { display = Table } self "display" [Ident "table-column-group"] = Just self { display = TableColumnGroup } - longhand _ self "display" [Ident "table-column"] = Just self {display = TableColumn} - longhand _ self "display" [Ident "table-caption"] = Just self {display=TableCaption} + longhand CSSBox { display = TableColumnGroup } self "display" [Ident "table-column"] = + Just self { display = TableColumn } + longhand CSSBox { display = Table } self "display" [Ident "table-caption"] = + Just self { display=TableCaption } longhand _ self "display" [Ident "initial"] = Just self {display = Block } + longhand _ self "caption-side" [Ident "top"] = Just self { captionBelow = False } + longhand _ self "caption-side" [Ident "bottom"] = Just self { captionBelow = True } + longhand _ self "caption-side" [Ident "initial"] = Just self {captionBelow = False} + + longhand a b c d | Just x <- longhand (font a) (font b) c d, + Just y <- longhand (font' a) (font' b) c d = + Just b { font = x, font' = y } -- Those properties can overlap! longhand a b c d | Just font' <- longhand (font a) (font b) c d = Just b { font = font' } + longhand a b c d | Just font <- longhand (font' a) (font' b) c d = Just b { + font' = font + } longhand a b c d | Just inner' <- longhand (inner a) (inner b) c d = Just b { inner = inner' } longhand _ _ _ _ = Nothing -{-finalizeCSS :: CSSBox -> LayoutItem Length-} +finalizeCSS :: PropertyParser x => Font' -> Font' -> StyleTree (CSSBox x) -> + LayoutItem Length Length x +finalizeCSS root parent self@StyleTree { + style = self'@CSSBox { display = Grid, inner = val }, children = childs + } = LayoutFlow val (finalizeBox self' font_) [ + finalizeGrid (gridStyles self') font_ (map cellStyles $ map style childs) + (map (finalizeCSS root font_) childs)] + where + font_ = pattern2font (font self') (font' self') parent root +finalizeCSS root parent self@StyleTree { + style = self'@CSSBox { display = Table, captionBelow = False }, children = childs + } = LayoutFlow (inner self') (finalizeBox self' font_) + ([finalizeCSS root font_ child { style = child' { display = Block } } + | child@StyleTree { style = child'@CSSBox { display = TableCaption } } <- childs] ++ + [finalizeTable root font_ (inner self') childs]) + where + font_ = pattern2font (font self') (font' self') parent root +finalizeCSS root parent self@StyleTree { + style = self'@CSSBox { display = Table, captionBelow = True }, children = childs + } = LayoutFlow (inner self') (finalizeBox self' font_) + (finalizeTable root font_ (inner self') childs: + [finalizeCSS root font_ child { style = child' { display = Block } } + | child@StyleTree { style = child'@CSSBox { display = TableCaption } } <- childs]) + where + font_ = pattern2font (font self') (font' self') parent root +finalizeCSS root parent self@StyleTree { + style = self'@CSSBox { inner = val }, children = childs + } = LayoutFlow val (finalizeBox self' font_) (map (finalizeCSS root font_) childs) + where + font_ = pattern2font (font self') (font' self') parent root +finalizeCSS' sysfont self@StyleTree { style = self' } = + finalizeCSS (pattern2font (font self') (font' self') sysfont sysfont) sysfont self + +finalizeBox self@CSSBox { cssBox = box } font_ = + mapY' (flip finalizeLength font_) $ mapX' (flip finalizeLength font_) box + +finalizeTable root parent val childs = LayoutFlow val lengthBox [] -- Placeholder! +{- finalizeTable root parent val childs = LayoutGrid val grid $ zip cells' childs' + where -- FIXME? How to handle non-table items in ? + grid = Grid { + rows = take width $ repeat ("", (0,"auto")), + rowBounds = [], + subgridRows = 0, + columns = take height $ repeat ("", (0,"auto")), + colBounds = [], + subgridCols = 0, + gap = Size (0,"px") (0,"px"), -- FIXME where to get this from? + containerSize = Size Auto Auto, -- Proper size is set on parent. + containerMin = Size Auto Auto, + containerMax = Size Auto Auto + } + cells' = adjustWidths cells + + (cells, width, height) = lowerCells childs + lowerCells (StyleTree self@CSSBox { display = TableRow } cells:rest) = + (row:rows, max rowwidth width', succ height) + where + (row, rowwidth) = lowerRow cells 0 -- FIXME: How to dodge colspans? + (rows, width', height') = lowerCells rest + lowerCells (StyleTree self@CSSBox { display = TableHeaderGroup } childs ) = + -} diff --git a/Graphics/Layout/CSS/Internal.hs b/Graphics/Layout/CSS/Internal.hs index cfaab20..a263792 100644 --- a/Graphics/Layout/CSS/Internal.hs +++ b/Graphics/Layout/CSS/Internal.hs @@ -1,12 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} module Graphics.Layout.CSS.Internal where -import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..)) +import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..), serialize) +import Stylist (PropertyParser(..)) import qualified Data.Text as Txt import Data.Scientific (toRealFloat) import Debug.Trace (trace) -- For warnings. +import Data.Maybe (fromMaybe) -import Graphics.Layout.Box hiding (lowerLength) +import Graphics.Layout.Box + +import Data.Text.Glyphize as HB +import Graphics.Text.Font.Choose (Pattern(..), Value(..), normalizePattern, getValue', getValue0) +import qualified Data.ByteString as B +import System.IO.Unsafe (unsafePerformIO) type Unitted = (Double, Txt.Text) auto :: Unitted @@ -24,35 +31,37 @@ parseLength' [Ident "min-content"] = Just (0,"min-content") parseLength' [Ident "max-content"] = Just (0,"max-content") parseLength' toks = parseLength toks -units = Txt.words "cap ch em ex ic lh rem rlh vh vw vmax vmin vb vi px cm mm Q in pc pt %" +units = Txt.words "cap ch em ex ic lh rem rlh vh vw vmax vmin px cm mm Q in pc pt %" n2f (NVInteger x) = realToFrac x n2f (NVNumber x) = toRealFloat x -lowerLength :: Unitted -> Font' -> Length -lowerLength (x,"cap") f = Pixels $ x*fontHeight f 'A' -lowerLength (x,"ch") f = Pixels $ x*fontAdvance f '0' -lowerLength (x,"em") f = Pixels $ x*fontSize f -lowerLength (x,"ex") f = Pixels $ x*fontHeight f 'x' -lowerLength (x,"ic") f = Pixels $ x*fontHeight f '水' -- CJK water ideograph -lowerLength (x,"lh") f = Pixels $ x*lineheight f -- Store conversion factors in `f`... -lowerLength (x,"rem") f = Pixels $ x*rootEm f -lowerLength (x,"rlh") f = Pixels $ x*rlh f -lowerLength (x,"vh") f = Pixels $ x*vh f -lowerLength (x,"vw") f = Pixels $ x*vw f -lowerLength (x,"vmax") f = Percent $ x*vmax f -lowerLength (x,"vmin") f = Percent $ x*vmin f -lowerLength (x,"vb") f = Percent $ x*vb f -- This'll be trickier to populate -lowerLength (x,"vi") f = Percent $ x*vi f -- This'll be trickier to populate -lowerLength (x,"px") f = Pixels $ x*scale f -lowerLength (x,"cm") f = Pixels $ x*scale f*96/2.54 -lowerLength (x,"mm") f | Pixels x' <- lowerLength (x,"cm") f = Pixels $ x'/10 -lowerLength (x,"Q") f | Pixels x' <- lowerLength (x,"cm") f = Pixels $ x'/40 -lowerLength (x,"pc") f | Pixels x' <- lowerLength (x,"in") f = Pixels $ x'/6 -lowerLength (x,"pt") f | Pixels x' <- lowerLength (x,"in") f = Pixels $ x'/72 -lowerLength (x,"%") _ = Percent $ x/100 -lowerLength (_,"auto") _ = Auto -lowerLength (_,unit) _ = trace ("Invalid unit " ++ Txt.unpack unit) $ Pixels 0 +finalizeLength :: Unitted -> Font' -> Length +finalizeLength (x,"cap") f = Pixels $ x*fontHeight f 'A' +finalizeLength (x,"ch") f = Pixels $ x*fontAdvance f '0' +finalizeLength (x,"em") f = Pixels $ x*fontSize f +finalizeLength (x,"") f = Pixels $ x*fontSize f -- For line-height. +finalizeLength (x,"ex") f = Pixels $ x*fontHeight f 'x' +finalizeLength (x,"ic") f = Pixels $ x*fontHeight f '水' -- CJK water ideograph +finalizeLength (x,"lh") f = Pixels $ x*lineheight f +finalizeLength (x,"rem") f = Pixels $ x*rootEm f +finalizeLength (x,"rlh") f = Pixels $ x*rlh f +finalizeLength (x,"vh") f = Pixels $ x*vh f +finalizeLength (x,"vw") f = Pixels $ x*vw f +finalizeLength (x,"vmax") f = Percent $ x*vmax f +finalizeLength (x,"vmin") f = Percent $ x*vmin f +finalizeLength (x,"px") f = Pixels $ x*scale f +finalizeLength (x,"cm") f = Pixels $ x*scale f*96/2.54 +finalizeLength (x,"in") f = Pixels $ x*96*scale f +finalizeLength (x,"mm") f | Pixels x' <- finalizeLength (x,"cm") f = Pixels $ x'/10 +finalizeLength (x,"Q") f | Pixels x' <- finalizeLength (x,"cm") f = Pixels $ x'/40 +finalizeLength (x,"pc") f | Pixels x' <- finalizeLength (x,"in") f = Pixels $ x'/6 +finalizeLength (x,"pt") f | Pixels x' <- finalizeLength (x,"in") f = Pixels $ x'/72 +finalizeLength (x,"%") _ = Percent $ x/100 +finalizeLength (_,"auto") _ = Auto +finalizeLength (_,"min-content") _ = Min +finalizeLength (_,"max-content") _ = Preferred +finalizeLength (_,unit) _ = trace ("Invalid unit " ++ Txt.unpack unit) $ Pixels 0 data Font' = Font' { fontHeight :: Char -> Double, @@ -65,7 +74,179 @@ data Font' = Font' { vw :: Double, vmax :: Double, vmin :: Double, - vb :: Double, - vi :: Double, scale :: Double } +placeholderFont = Font' (const 0) (const 0) 0 0 0 0 0 0 0 0 1 + +pattern2hbfont :: Pattern -> [Variation] -> Font +pattern2hbfont pat variations = createFontWithOptions options face + where + bytes = unsafePerformIO $ B.readFile $ getValue0 "file" pat + face = createFace bytes $ toEnum $ fromMaybe 0 $ getValue' "index" pat + options = foldl value2opt defaultFontOptions $ normalizePattern pat + + value2opt opts ("slant", (_, ValueInt x):_) = opts { + optionSynthSlant = Just $ realToFrac x + } + value2opt opts ("fontvariations", _:_) = opts {optionVariations = variations} + value2opt opts _ = opts + +pattern2font :: Pattern -> CSSFont -> Font' -> Font' -> Font' +pattern2font pat styles parent root = Font' { + fontHeight = height' . fontGlyphExtents font' . fontGlyph', + fontAdvance = fromIntegral . fontGlyphHAdvance font' . fontGlyph', + fontSize = fontSize', + rootEm = fontSize root, + lineheight = lineheight', + rlh = lineheight root, + + vh = vh root, + vw = vw root, + vmax = vmax root, + vmin = vmin root, + scale = scale root + } where + height' (Just x) = fromIntegral $ HB.height x + height' Nothing = fontSize' + lineheight' | snd (cssLineheight styles) == "normal", + Just extents <- fontHExtents font' = fromIntegral $ lineGap extents + | otherwise = lowerLength' (cssLineheight styles) parent + fontSize' = lowerLength' (cssFontSize styles) parent + lowerLength' a = lowerLength (fontSize parent) . finalizeLength a + fontGlyph' ch = fromMaybe 0 $ fontGlyph font' ch Nothing + font' = pattern2hbfont pat $ variations' fontSize' styles + +data CSSFont = CSSFont { + cssFontSize :: Unitted, + cssLineheight :: Unitted, + variations :: [Variation], + weightVariation :: Variation, + widthVariation :: Variation, + slantVariation :: Variation, + opticalSize :: Bool, + defaultFontSize :: Unitted +} +variations' :: Double -> CSSFont -> [Variation] +variations' fontsize self = + (if opticalSize self then (Variation opsz (realToFrac fontsize):) else id) + (slantVariation self:widthVariation self:weightVariation self:variations self) + +fracDefault :: CSSFont -> Double -> Maybe CSSFont +fracDefault self frac = Just self { + cssFontSize = (frac*fst (defaultFontSize self),snd $ defaultFontSize self) +} +instance PropertyParser CSSFont where + temp = CSSFont { + cssFontSize = (12,"pt"), + cssLineheight = (1,""), + variations = [], + weightVariation = Variation wght 400, + widthVariation = Variation wdth 100, + slantVariation = Variation ital 0, + opticalSize = True, + defaultFontSize = (12,"pt") -- NOTE: Callers should load from system settings. + } + inherit parent = parent + + longhand _ self "font-size" [Ident "xx-small"] = fracDefault self $ 3/5 + longhand _ self "font-size" [Ident "x-small"] = fracDefault self $ 3/4 + longhand _ self "font-size" [Ident "small"] = fracDefault self $ 8/9 + longhand _ self "font-size" [Ident "medium"] = fracDefault self 1 + longhand _ self "font-size" [Ident "large"] = fracDefault self $ 6/5 + longhand _ self "font-size" [Ident "x-large"] = fracDefault self $ 3/2 + longhand _ self "font-size" [Ident "xx-large"] = fracDefault self 2 + longhand _ self "font-size" [Ident "xxx-large"] = fracDefault self 3 + longhand parent self "font-size" [Ident "larger"] = + Just self { cssFontSize = (x*1.2,unit) } + where (x,unit) = cssFontSize parent + longhand parent self "font-size" [Ident "smaller"] = + Just self { cssFontSize = (x/1.2,unit) } + where (x, unit) = cssFontSize parent + longhand _ self "font-size" toks + | Just x <- parseLength toks = Just self { cssFontSize = x } + + longhand _ self "line-height" [Ident "normal"] = Just self { cssLineheight = (0,"normal") } + longhand _ self "line-height" [Number _ x] = Just self { cssLineheight = (n2f x,"em") } + longhand _ self "line-height" toks + | Just x <- parseLength toks = Just self { cssLineheight = x } + + longhand _ self "font-variation-settings" [Ident "normal"] = Just self { variations = [] } + longhand _ self "font-variation-settings" [Ident "initial"] = Just self {variations = []} + longhand _ self "font-variation-settings" toks + | Just x <- parseVariations toks = Just self { variations = x } + + longhand _ self "font-weight" [Ident "normal"] = + Just self { weightVariation = Variation wght 400 } + longhand _ self "font-weight" [Ident "initial"] = + Just self { weightVariation = Variation wght 400 } + longhand _ self "font-weight" [Ident "bold"] = + Just self { weightVariation = Variation wght 700 } + longhand _ self "font-weight" [Number _ (NVInteger x)] | x >= 100 && x < 1000 = + Just self { weightVariation = Variation wght $ fromIntegral x } + longhand parent self "font-weight" [Ident "bolder"] + | varValue (weightVariation parent) < 400 = + Just self { weightVariation = Variation wght 400 } + | varValue (weightVariation parent) < 600 = + Just self { weightVariation = Variation wght 700 } + | otherwise = Just self { weightVariation = Variation wght 900 } + longhand parent self "font-weight" [Ident "lighter"] + | varValue (weightVariation parent) < 600 = + Just self { weightVariation = Variation wght 100 } + | varValue (weightVariation parent) < 800 = + Just self { weightVariation = Variation wght 400 } + | otherwise = Just self { weightVariation = Variation wght 700 } + + longhand _ self "font-stretch" [Ident "ultra-condensed"] = + Just self { widthVariation = Variation wdth 50 } + longhand _ self "font-stretch" [Ident "extra-condensed"] = + Just self { widthVariation = Variation wdth 62.5 } + longhand _ self "font-stretch" [Ident "condensed"] = + Just self { widthVariation = Variation wdth 75 } + longhand _ self "font-stretch" [Ident "semi-condensed"] = + Just self { widthVariation = Variation wdth 87.5 } + longhand _ self "font-stretch" [Ident k] | k `elem` ["initial", "normal"] = + Just self { widthVariation = Variation wdth 100 } + longhand _ self "font-stretch" [Ident "semi-expanded"] = + Just self { widthVariation = Variation wdth 112.5 } + longhand _ self "font-stretch" [Ident "expanded"] = + Just self { widthVariation = Variation wdth 125 } + longhand _ self "font-stretch" [Ident "extra-expanded"] = + Just self { widthVariation = Variation wdth 150 } + longhand _ self "font-stretch" [Ident "ultra-expanded"] = + Just self { widthVariation = Variation wdth 200 } + longhand _ self "font-stretch" [Percentage _ x] = + Just self { widthVariation = Variation wdth $ n2f x } + + longhand _ self "font-style" [Ident "oblique", Dimension _ x "deg"] = + Just self { slantVariation = Variation slnt $ n2f x } + longhand _ self "font-style" [Ident "oblique", Dimension _ x "grad"] = + Just self { slantVariation = Variation slnt (n2f x/400*360) } + longhand _ self "font-style" [Ident "oblique", Dimension _ x "rad"] = + Just self { slantVariation = Variation slnt (n2f x*180/pi) } + longhand _ self "font-style" [Ident "oblique", Dimension _ x "turn"] = + Just self { slantVariation = Variation slnt (n2f x*360) } + longhand _ self "font-style" [Ident "italic"] = + Just self { slantVariation = Variation ital 1 } + longhand _ self "font-style" [Ident "normal"] = + Just self { slantVariation = Variation ital 0 } + longhand _ self "font-style" [Ident "initial"] = + Just self { slantVariation = Variation ital 0 } + + longhand _ s "font-optical-sizing" [Ident "auto"] = Just s {opticalSize = True} + longhand _ s "font-optical-sizing" [Ident "initial"] = Just s {opticalSize = True} + longhand _ s "font-optical-sizing" [Ident "none"] = Just s {opticalSize = False} + + longhand _ _ _ _ = Nothing + +parseVariations (x@(String _):y@(Number _ _):Comma:toks) + | Just var <- parseVariation $ Txt.unpack $ serialize [x, y], + Just vars <- parseVariations toks = Just $ var:vars +parseVariations toks@[String _, Number _ _] + | Just var <- parseVariation $ Txt.unpack $ serialize toks = Just [var] +parseVariations _ = Nothing + +wght = tag_from_string "wght" +wdth = tag_from_string "wdth" +slnt = tag_from_string "slnt" +ital = tag_from_string "ital" +opsz = tag_from_string "opsz" diff --git a/Graphics/Layout/Grid/CSS.hs b/Graphics/Layout/Grid/CSS.hs index 713c033..bd6259d 100644 --- a/Graphics/Layout/Grid/CSS.hs +++ b/Graphics/Layout/Grid/CSS.hs @@ -9,7 +9,7 @@ import Data.Char (isAlphaNum) import Data.Maybe (fromMaybe) import Graphics.Layout.CSS.Internal -import Graphics.Layout.Box hiding (lowerLength) +import Graphics.Layout.Box import Graphics.Layout.Grid import Graphics.Layout @@ -257,14 +257,14 @@ finalizeGrid self@CSSGrid { } font cells childs = LayoutGrid temp self' $ zip cells' childs where self' = Grid { - rows = map lowerFR $ map snd rows0, + rows = map finalizeFR $ map snd rows0, rowBounds = [], subgridRows = 0, -- disable - columns = map lowerFR $ map snd cols0, + columns = map finalizeFR $ map snd cols0, colBounds = [], subgridColumns = 0, -- disable - gap = Size (lowerLength (inline $ cssGap self) font) - (lowerLength (block $ cssGap self) font), + gap = Size (finalizeLength (inline $ cssGap self) font) + (finalizeLength (block $ cssGap self) font), containerSize = Size Auto Auto, -- Proper size is set on parent. containerMin = Size Auto Auto, containerMax = Size Auto Auto @@ -280,6 +280,12 @@ finalizeGrid self@CSSGrid { finalizeCells [] rows cols = ([], rows, cols) finalizeCell :: CSSCell -> [([Text], Unitted)] -> [([Text], Unitted)] -> (GridItem Length Length, [([Text], Unitted)], [([Text], Unitted)]) + finalizeCell cell@CSSCell { + rowStart = Autoplace, columnStart = Autoplace + } rows cols | autoFlow self == Row = + finalizeCell cell { columnStart = Numbered 1 Nothing } rows cols + | autoFlow self == Col = + finalizeCell cell { rowStart = Numbered 1 Nothing } rows cols finalizeCell cell rows cols = (GridItem { startRow = startRow', endRow = endRow', startCol = startCol', endCol = endCol', @@ -294,6 +300,7 @@ finalizeGrid self@CSSGrid { (startCol', endCol', cols') = lowerTrack2 cols ([], autoColumns self) (columnStart cell) (columnEnd cell) + lowerTrack2 tracks auto start Autoplace = lowerTrack2 tracks auto start $ Span 1 Nothing lowerTrack2 tracks auto start@(Span _ _) end@(Span _ _) = lowerTrack2 tracks auto start $ Numbered (pred $ length tracks) Nothing lowerTrack2 tracks auto start@(Span _ _) end = (start', end', tracks') @@ -326,8 +333,8 @@ finalizeGrid self@CSSGrid { drop (abs start) $ enumerate (tracks0 ++ repeat ([name],auto)), name `elem` names] - lowerFR (x,"fr") = Right x - lowerFR x = Left $ lowerLength x font + finalizeFR (x,"fr") = Right x + finalizeFR x = Left $ finalizeLength x font finalizeGrid self@CSSGrid { templateColumns = Right colnames } font cells childs = LayoutGrid val' self' { subgridColumns = length colnames } childs' where diff --git a/app/Main.hs b/app/Main.hs index 65ae4a0..45d1dad 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,214 @@ 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.Internal (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 = putStrLn "Hello, Haskell!" +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; }" + ] diff --git a/cattrap.cabal b/cattrap.cabal index 030e948..2b3a8c4 100644 --- a/cattrap.cabal +++ b/cattrap.cabal @@ -22,7 +22,7 @@ library Graphics.Layout.CSS.Internal, Graphics.Layout.Grid.CSS -- other-modules: -- other-extensions: - build-depends: base >=4.12 && <4.16, css-syntax, scientific, text, stylist-traits, fontconfig-pure, harfbuzz-pure + build-depends: base >=4.12 && <4.16, css-syntax, scientific, text, stylist-traits, fontconfig-pure, harfbuzz-pure, bytestring -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wincomplete-patterns @@ -31,7 +31,7 @@ executable cattrap main-is: Main.hs -- other-modules: -- other-extensions: - build-depends: base >=4.12 && <4.16 + build-depends: base >=4.12 && <4.16, cattrap, xml, text, css-syntax, stylist-traits, GLUT, gl hs-source-dirs: app default-language: Haskell2010 -- 2.30.2