M Graphics/Layout.hs => Graphics/Layout.hs +4 -0
@@ 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')
M Graphics/Layout/CSS.hs => Graphics/Layout/CSS.hs +97 -13
@@ 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 <table>?
+ 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 ) =
+ -}
M Graphics/Layout/CSS/Internal.hs => Graphics/Layout/CSS/Internal.hs +210 -29
@@ 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"
M Graphics/Layout/Grid/CSS.hs => Graphics/Layout/Grid/CSS.hs +14 -7
@@ 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
M app/Main.hs => app/Main.hs +211 -1
@@ 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; }"
+ ]
M cattrap.cabal => cattrap.cabal +2 -2
@@ 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