cattrap 0.2.0.0 → 0.3.0.0

raw patch · 12 files changed

+523/−312 lines, 12 filesdep +deepseqdep +directorydep +file-embeddep −GLUTdep −gldep ~balkondep ~fontconfig-puredep ~stylist-traitsnew-component:exe:cattrap-argonautnew-component:exe:cattrap-stylistPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, directory, file-embed, html-conduit, hurl, hurl-xml, network-uri, parallel, sdl2, stylist, xml-conduit, xml-conduit-stylist

Dependencies removed: GLUT, gl

Dependency ranges changed: balkon, fontconfig-pure, stylist-traits, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• Graphics/Layout.hs +34/−24
• Graphics/Layout/Box.hs +12/−5
• Graphics/Layout/CSS.hs +23/−19
• Graphics/Layout/CSS/Length.hs +13/−3
• Graphics/Layout/CSS/Parse.hs +68/−82
• Graphics/Layout/Grid.hs +7/−3
• Graphics/Layout/Inline.hs +18/−14
• app/Integration.hs +198/−0
• app/Integration2.hs +69/−0
• app/Main.hs +51/−156
• cattrap.cabal +23/−6

@@ -3,3 +3,10 @@ ## 0.1.0.0 -- YYYY-mm-dd  * First version. Released on an unsuspecting world.++## 0.2.0.0 -- 2023-06-03++* Integrate richtext support.+* Add shorthand properties.+* Add logical properties based on text-direction.+* Propagate prioritized properties.

@@ -14,6 +14,8 @@                                 ParagraphLayout(..), layoutRich) import Data.Text.ParagraphLayout (paginate, PageContinuity(..), PageOptions(..)) import Stylist (PropertyParser(temp))+import Control.Parallel.Strategies+import Control.DeepSeq (NFData(..))  import Graphics.Layout.Box as B import Graphics.Layout.Grid as G@@ -53,6 +55,10 @@ nullLayout :: (PropertyParser x, Zero m, Zero n) => LayoutItem m n x nullLayout = LayoutFlow temp zero [] +instance (Zero m, CastDouble m, NFData m, Zero n, CastDouble n, NFData n) =>+        NFData (LayoutItem m n x) where+    rnf = rnf . layoutGetBox -- Avoid auxiliary properties that don't cleanly `rnf`+ --- | Retrieve the surrounding box for a layout item. layoutGetBox :: (Zero m, Zero n, CastDouble m, CastDouble n) =>         LayoutItem m n x -> PaddedBox m n@@ -92,14 +98,14 @@ setCellBox' (child, cell) = setCellBox cell $ layoutGetBox child  -- | Update a (sub)tree to compute & cache minimum legible sizes.-boxMinWidth :: (Zero y, CastDouble y) =>+boxMinWidth :: (Zero y, CastDouble y, NFData y) =>         Maybe Double -> LayoutItem y Length x -> LayoutItem y Length x boxMinWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs'   where     self' = self { B.min = mapSizeX (B.mapAuto min') (B.min self) }     min' = flowMinWidth parent' self childs''     childs'' = map (mapX' $ lowerLength selfWidth) $ map layoutGetBox childs'-    childs' = map (boxMinWidth $ Just selfWidth) childs+    childs' = parMap' (boxMinWidth $ Just selfWidth) childs     selfWidth = width $ mapX' (lowerLength parent') self     parent' = fromMaybe 0 parent boxMinWidth parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' cells' childs'@@ -108,7 +114,7 @@     cells = sizeTrackMins parent' (inline self) $ map inline cells'     cells' = map setCellBox' $ zip childs' cells0 -- Flatten subgrids     childs'' = map (mapX' $ lowerLength selfWidth) $ map layoutGetBox childs'-    childs' = map (boxMinWidth $ Just selfWidth) childs+    childs' = parMap' (boxMinWidth $ Just selfWidth) childs     selfWidth = trackNat (lowerLength parent') $ inline self     parent' = fromMaybe (gridEstWidth self cells0) parent     zeroBox :: PaddedBox Double Double@@ -119,14 +125,14 @@     LayoutConst val self' $ map (boxMinWidth Nothing) childs boxMinWidth _ self@(LayoutSpan _) = self -- | Update a (sub)tree to compute & cache ideal width.-boxNatWidth :: (Zero y, CastDouble y) =>+boxNatWidth :: (Zero y, CastDouble y, NFData y) =>         Maybe Double -> LayoutItem y Length x -> LayoutItem y Length x boxNatWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs'   where     self' = self { B.nat = Size size' $ block $ B.nat self }     size' = flowNatWidth parent' self childs''     childs'' = map (mapX' $ lowerLength selfWidth) $ map layoutGetBox childs'-    childs' = map (boxNatWidth $ Just selfWidth) childs+    childs' = parMap' (boxNatWidth $ Just selfWidth) childs     selfWidth = width $ mapX' (lowerLength parent') self     parent' = fromMaybe 0 parent boxNatWidth parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' cells' childs'@@ -135,7 +141,7 @@     cells = sizeTrackNats parent' (inline $ self) $ map inline cells'     cells' = map setCellBox' $ zip childs' cells0 -- Flatten subgrids     childs'' = map (mapX' $ lowerLength selfWidth) $ map layoutGetBox childs'-    childs' = map (boxNatWidth $ Just selfWidth) childs+    childs' = parMap' (boxNatWidth $ Just selfWidth) childs     selfWidth = trackNat (lowerLength parent') $ inline self     parent' = fromMaybe (gridEstWidth self cells0) parent     zeroBox :: PaddedBox Double Double@@ -146,16 +152,17 @@     LayoutConst val self' $ map (boxNatWidth Nothing) childs boxNatWidth _ self@(LayoutSpan _) = self -- | Update a (sub)tree to compute & cache maximum legible width.-boxMaxWidth :: CastDouble y => PaddedBox a Double -> LayoutItem y Length x -> LayoutItem y Length x+boxMaxWidth :: (CastDouble y, Zero y, NFData y) =>+        PaddedBox a Double -> LayoutItem y Length x -> LayoutItem y Length x boxMaxWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs'   where-    childs' = map (boxMaxWidth self'') childs+    childs' = parMap' (boxMaxWidth self'') childs     self'' = mapX' (lowerLength $ inline $ B.size parent) self'     self' = self { B.max = Size (Pixels max') (block $ B.max self) }     max' = flowMaxWidth parent self boxMaxWidth parent (LayoutGrid val self cells childs) = LayoutGrid val self cells childs'   where -- Propagate parent track as default.-    childs' = map inner $ zip cells childs+    childs' = parMap' inner $ zip cells childs     inner (Size cellx celly, child) =         boxMaxWidth (cellSize (inline self) cellx `size2box` cellSize (block self) celly) child     size2box x y = zeroBox { B.min = Size x y, B.max = Size x y, B.size = Size x y }@@ -165,18 +172,18 @@     map (boxMaxWidth $ mapY' toDouble $ mapX' toDouble self') childs boxMaxWidth parent self@(LayoutSpan _) = self -- | Update a (sub)tree to compute & cache final width.-boxWidth :: (Zero y, CastDouble y) => PaddedBox b Double -> LayoutItem y Length x ->-        LayoutItem y Double x+boxWidth :: (Zero y, CastDouble y, NFData y) =>+        PaddedBox b Double -> LayoutItem y Length x -> LayoutItem y Double x boxWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs'   where-    childs' = map (boxWidth self') childs+    childs' = parMap' (boxWidth self') childs     self' = (mapX' (lowerLength $ inline $ size parent) self) {         size = Size size' $ block $ B.max self       }     size' = flowWidth parent self boxWidth parent (LayoutGrid val self cells childs) = LayoutGrid val self' cells' childs'   where -- Propagate parent track as default-    (cells', childs') = unzip $ map recurse $ zip cells childs+    (cells', childs') = unzip $ parMap' recurse $ zip cells childs     recurse (cell, child) = (cell', child')       where         cell' = setCellBox cell $ layoutGetBox child'@@ -207,13 +214,13 @@     self' = self { size = mapSizeY (mapAuto size') (size self) }     size' = flowNatHeight parent self childs''     childs'' = map (mapY' (lowerLength parent)) $ map layoutGetBox childs'-    childs' = map (boxNatHeight $ inline $ size self) childs+    childs' = parMap' (boxNatHeight $ inline $ size self) childs boxNatHeight parent (LayoutGrid val self cells childs) = LayoutGrid val self' cells childs'   where     self' = Size (inline self) (block self) { trackNats = heights }     heights = sizeTrackNats parent (block self) $ map block cells'     cells' = map setCellBox' $ zip childs' cells -- Flatten subgrids-    childs' = map (boxNatHeight width) childs+    childs' = parMap' (boxNatHeight width) childs     width = trackNat id $ inline self boxNatHeight parent self@(LayoutInline _ _ _) = self boxNatHeight parent self@(LayoutInline' _ _ _) = self@@ -224,12 +231,12 @@ boxMinHeight :: Double -> LayoutItem Length Double x -> LayoutItem Length Double x boxMinHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs'   where-    childs' = map (boxMinHeight $ inline $ size self) childs+    childs' = parMap' (boxMinHeight $ inline $ size self) childs     self' = self { B.min = Size (inline $ B.min self) (Pixels min') }     min' = flowMinHeight parent self boxMinHeight parent (LayoutGrid val self cells childs) = LayoutGrid val self' cells' childs'   where-    (cells', childs') = unzip $ map recurse $ zip cells childs+    (cells', childs') = unzip $ parMap' recurse $ zip cells childs     recurse (cell, child) = (cell', child') -- Propagate track into subgrids.       where         cell' = setCellBox cell (layoutGetBox child')@@ -247,13 +254,13 @@         LayoutItem Length Double x boxMaxHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs'   where-    childs' = map (boxMaxHeight $ mapY' (lowerLength width) self') childs+    childs' = parMap' (boxMaxHeight $ mapY' (lowerLength width) self') childs     self' = self { B.max = Size (inline $ B.max self) (Pixels max') }     max' = flowMaxHeight (inline $ size parent) self     width = inline $ size self boxMaxHeight parent (LayoutGrid val self cells childs) = LayoutGrid val self cells' childs'   where-    (cells', childs') = unzip $ map recurse $ zip cells childs+    (cells', childs') = unzip $ parMap' recurse $ zip cells childs     recurse (cell, child) = (cell', child') -- Propagate track into subgrids       where         cell' = setCellBox cell (layoutGetBox child')@@ -269,7 +276,7 @@ boxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> LayoutItem Double Double x boxHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs'   where-    childs' = map (boxHeight self') childs+    childs' = parMap' (boxHeight self') childs     self' = (mapY' (lowerLength $ inline $ size parent) self) {         size = Size (inline $ size self) size'       }@@ -277,7 +284,7 @@     width = inline $ size self boxHeight parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' cells' childs'   where-    (cells', childs') = unzip $ map recurse $ zip cells0 childs+    (cells', childs') = unzip $ parMap' recurse $ zip cells0 childs     recurse (cell, child) = (cell', child') -- Propagate track into subgrids.       where         cell' = setCellBox cell (layoutGetBox child')@@ -351,12 +358,12 @@     LayoutItem Double Double x -> LayoutItem Double Double ((Double, Double), x) boxPosition pos@(x, y) (LayoutFlow val self childs) = LayoutFlow (pos, val) self childs'   where-    childs' = map recurse $ zip pos' childs+    childs' = parMap' recurse $ zip pos' childs     recurse ((Size x' y'), child) = boxPosition (x + x', y + y') child     pos' = positionFlow $ map layoutGetBox childs boxPosition pos@(x, y) (LayoutGrid val self cells childs) = LayoutGrid (pos, val) self cells childs'   where-    childs' = map recurse $ zip pos' childs+    childs' = parMap' recurse $ zip pos' childs     recurse ((x', y'), child) = boxPosition (x + x', y + y') child     pos' = gridPosition self cells boxPosition pos@(x, y) (LayoutInline val self paging) =@@ -364,7 +371,7 @@ boxPosition pos@(x, y) self@(LayoutInline' val _ _) =     boxPosition pos $ LayoutConst val (layoutGetBox self) $ layoutGetChilds self boxPosition pos (LayoutConst val self childs) =-    LayoutConst (pos, val) self $ map (boxPosition pos) childs+    LayoutConst (pos, val) self $ parMap' (boxPosition pos) childs boxPosition pos (LayoutSpan self) = LayoutSpan $ positionTree pos self -- | Compute sizes & position information for all nodes in the (sub)tree. boxLayout :: (PropertyParser x, Eq x) => PaddedBox Double Double ->@@ -392,3 +399,6 @@     (pattern font, fontSize font) `M.singleton` IS.fromList glyphs   where glyphs = map fromEnum $ map Hb.codepoint $ map fst $ fragmentGlyphs self glyphsPerFont node = M.unionsWith IS.union $ map glyphsPerFont $ layoutGetChilds node -}++parMap' :: NFData b => (a -> b) -> [a] -> [b]+parMap' = parMap rdeepseq

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, DeriveGeneric #-} -- | Datastructures representing the CSS box model, -- & utilities for operating on them. module Graphics.Layout.Box(Border(..), mapX, mapY,@@ -8,10 +8,14 @@         leftSpace, rightSpace, topSpace, bottomSpace, hSpace, vSpace,         Length(..), mapAuto, lowerLength, Zero(..), CastDouble(..)) where +import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+ -- | Amount of space surrounding the box. data Border m n = Border {     top :: m, bottom :: m, left :: n, right :: n-} deriving Eq+} deriving (Eq, Read, Show, Generic)+instance (NFData m, NFData n) => NFData (Border m n) -- | Convert horizontal spacing via given callback. mapX :: (n -> nn) -> Border m n -> Border m nn -- | Convert vertical spacing via given callback.@@ -21,7 +25,8 @@  -- | 2D size of a box. Typically inline is width & block is height. -- This may change as support for vertical layout is added.-data Size m n = Size {inline :: n, block :: m} deriving (Eq, Show)+data Size m n = Size {inline :: n, block :: m} deriving (Eq, Show, Read, Generic)+instance (NFData m, NFData n) => NFData (Size m n) -- | Convert inline size via given callback mapSizeY :: (m -> mm) -> Size m n -> Size mm n mapSizeY cb self = Size (inline self) (cb $ block self)@@ -45,7 +50,8 @@     border :: Border m n,     -- | The amount of space between the border & anything else.     margin :: Border m n-} deriving Eq+} deriving (Eq, Read, Show, Generic)+instance (NFData m, NFData n) => NFData (PaddedBox m n) -- | An empty box, takes up nospace onscreen. zeroBox :: PaddedBox Double Double zeroBox = PaddedBox {@@ -124,7 +130,8 @@         | Auto -- ^ Use normal layout computations.         | Preferred -- ^ Use computed preferred width.         | Min -- ^ Use minimum legible width.-        deriving Eq+        deriving (Eq, Read, Show, Generic)+instance NFData Length  -- | Convert a length given the container's width. Filling in 0 for keywords. -- If you wish for keywords to be handled differently, callers need to compute

@@ -9,8 +9,7 @@ import qualified Data.Text as Txt import Stylist (PropertyParser(..)) import Stylist.Tree (StyleTree(..))-import Data.Text.ParagraphLayout.Rich (paragraphLineHeight, constructParagraph,-        defaultParagraphOptions, defaultBoxOptions,+import Data.Text.ParagraphLayout.Rich (constructParagraph, defaultBoxOptions,         LineHeight(..), InnerNode(..), Box(..), RootNode(..))  import Graphics.Layout.Box as B@@ -22,41 +21,48 @@  import Data.Char (isSpace) import Graphics.Layout.CSS.Parse+import Data.Maybe (fromMaybe)  instance (PropertyParser x, Zero m, Zero n) => Default (UserData m n x) where     def = ((placeholderFont, 0), zero, temp) +inner' :: PropertyParser x => Font' -> CSSBox x -> x+inner' f self = foldr apply (inner self) $ innerProperties self+  where apply (k, v) ret = fromMaybe ret $+            longhand (innerParent self) ret k $ finalizeLengths f v+ -- | Desugar parsed CSS into more generic layout parameters. finalizeCSS :: PropertyParser x => Font' -> Font' -> StyleTree (CSSBox x) ->         LayoutItem Length Length x finalizeCSS root parent StyleTree { style = self'@CSSBox { display = None } } =-    LayoutFlow (inner self') lengthBox []+    LayoutFlow (inner' parent self') lengthBox [] finalizeCSS root parent self@StyleTree {-    style = self'@CSSBox { display = Grid, inner = val }, children = childs-  } = LayoutFlow val (finalizeBox self' font_) [+    style = self'@CSSBox { display = Grid }, children = childs+  } = LayoutFlow (inner' font_ self') (finalizeBox self' font_) [         finalizeGrid (gridStyles self') font_ (map cellStyles $ map style childs)             (finalizeChilds root font_ self' 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_)+        style=self'@CSSBox {display=Table, captionBelow=False}, children=childs+    } = LayoutFlow (inner' font_ 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_)+        style = self'@CSSBox {display=Table, captionBelow=True}, children = childs+    } = LayoutFlow (inner' font_ self') (finalizeBox self' font_)         (finalizeTable root font_ temp 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_) (finalizeChilds root font_ self' childs)+    style = self', children = childs+  } = LayoutFlow (inner' font_ self') (finalizeBox self' font_)+        (finalizeChilds root font_ self' childs)   where     font_ = pattern2font (font self') (font' self') parent root finalizeCSS' sysfont self@StyleTree { style = self' } =@@ -69,10 +75,10 @@     finalizeChilds root parent style' childs finalizeChilds root parent style' childs@(child:childs')     | isInlineTree childs, Just self <- finalizeParagraph (flattenTree0 childs) =-        [LayoutInline (inherit $ inner style') self paging]+        [LayoutInline (inherit $ inner' parent style') self paging]     | (inlines@(_:_), blocks) <- spanInlines childs,         Just self <- finalizeParagraph (flattenTree0 inlines) =-            LayoutInline (inherit $ inner style') self paging :+            LayoutInline (inherit $ inner' parent style') self paging :                 finalizeChilds root parent style' blocks     | (StyleTree { style = CSSBox { display = Inline } }:childs') <- childs =         finalizeChilds root parent style' childs' -- Inline's all whitespace...@@ -100,19 +106,17 @@         buildInline f i self $ map (flattenTree f) $ enumerate child       where f = pattern2font (font self) (font' self) p root     flattenTree f (i,StyleTree {style=self@CSSBox {inlineStyles=CSSInline txt _ _}})-        = buildInline f i self [TextSequence ((f,0),zero,inherit $ inner self) txt]+        = buildInline f i self [+            TextSequence ((f, 0), zero, inherit $ inner' parent self) txt]     buildInline f i self childs =-        InlineBox ((f, i), finalizeBox self f, inner self)+        InlineBox ((f, i), finalizeBox self f, inner' parent self)                 (Box childs' $ flip applyFontInline f $ txtOpts self)                 defaultBoxOptions -- Fill in during layout.       where childs' = applyBidi (inlineStyles self) childs     finalizeParagraph (RootBox (Box [TextSequence _ txt] _))         | Txt.all isSpace txt = Nothing -- Discard isolated whitespace.     finalizeParagraph tree =-        Just $ constructParagraph "" tree "" defaultParagraphOptions {-            paragraphLineHeight = Absolute $ toEnum $ fromEnum-                    (lineheight parent * hbUnit)-          }+        Just $ constructParagraph "" tree "" $ paragraphOptions style'     enumerate = zip $ enumFrom 0 finalizeChilds _ _ _ [] = [] 

@@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -- | Infrastructure for parsing & desugaring length units & keywords, -- in reference to the selected font.-module Graphics.Layout.CSS.Length(Unitted, auto, parseLength, parseLength',-        n2f, finalizeLength, px2pt, Font'(..)) where+module Graphics.Layout.CSS.Length(Unitted, auto, parseLength, parseLength', units,+        n2f, finalizeLength, finalizeLengths, px2pt, Font'(..)) where  import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..)) import qualified Data.Text as Txt-import Data.Scientific (toRealFloat)+import Data.Scientific (toRealFloat, fromFloatDigits) import Debug.Trace (trace) -- For warnings. import Data.Text.Glyphize (Font) import Graphics.Text.Font.Choose (Pattern(..))@@ -27,6 +27,7 @@ parseLength [Dimension _ x unit]     | n2f x == 0 && unit == "" = Just (0,"px")     | unit `elem` units = Just (n2f x,unit)+parseLength [Number _ x] | n2f x == 0 = Just (0,"px") parseLength [Ident "auto"] = Just (0,"auto") parseLength [Ident "initial"] = Just (0,"auto") parseLength _ = Nothing@@ -75,6 +76,15 @@ finalizeLength (_,unit) _ = trace ("Invalid unit " ++ Txt.unpack unit) $ Pixels 0 -- | Convert from a computed length to the "pt" unit. px2pt f x = x / scale f / 96 * 72++-- | Convert any length-units in the given CSS tokens to device pixels+finalizeLengths :: Font' -> [Token] -> [Token]+finalizeLengths f (Dimension _ x unit:toks)+    | unit `elem` units, Pixels y <- finalizeLength (n2f x,unit) f =+        Dimension "" (NVNumber $ fromFloatDigits y) "px":finalizeLengths f toks+finalizeLengths f (Number a b:ts)|n2f b==0=Dimension a b "px":finalizeLengths f ts+finalizeLengths f (tok:toks) = tok:finalizeLengths f toks+finalizeLengths _ [] = []  -- | A Harfbuzz font with sizing parameters. data Font' = Font' {

@@ -5,18 +5,21 @@ import Stylist (PropertyParser(..), TrivialPropertyParser, parseOperands,                 parseUnorderedShorthand', parseUnorderedShorthand) import Data.Text.ParagraphLayout (PageOptions(..))-import Data.Text.ParagraphLayout.Rich (textDirection)+import Data.Text.ParagraphLayout.Rich (textDirection, ParagraphOptions,+            defaultParagraphOptions, paragraphAlignment, ParagraphAlignment(..)) import Data.Text.Glyphize (Direction(..))  import Graphics.Layout.Box as B import Graphics.Text.Font.Choose (Pattern, unset)-import Graphics.Layout.CSS.Length (Unitted, parseLength', parseLength, auto)+import Graphics.Layout.CSS.Length (Unitted, parseLength', parseLength, auto, units) import Graphics.Layout.CSS.Font (CSSFont) import Graphics.Layout.Grid.CSS (CSSGrid(..), CSSCell(..), Placement(..)) import Graphics.Layout.Inline.CSS (CSSInline(..))  import Data.Maybe (isJust, fromMaybe) import qualified Data.HashMap.Lazy as HM+import Data.Text (Text)+import Debug.Trace (trace) -- For debug warnings.  -- | Parsed CSS properties relevant to layout. data CSSBox a = CSSBox {@@ -33,6 +36,10 @@     font' :: CSSFont,     -- | Caller-specified data, to parse additional CSS properties.     inner :: a,+    -- | Properties to lower size units before passing onto to `inner`+    innerProperties :: [(Text, [Token])],+    -- | Parent to use when parsing length-expanded inner properties.+    innerParent :: a,     -- | Grid-related CSS properties.     gridStyles :: CSSGrid,     -- | Grid item related CSS properties.@@ -42,7 +49,9 @@     -- | Parsed CSS caption-side.     captionBelow :: Bool,     -- | Parsed widows & orphans controlling pagination.-    pageOptions :: PageOptions+    pageOptions :: PageOptions,+    -- | Parsed text-alignment & other options which applies per-paragraph.+    paragraphOptions :: ParagraphOptions } -- | Accessor for inlineStyle's `textDirection` attribute. direction CSSBox { inlineStyles = CSSInline _ opts _ } = textDirection opts@@ -77,11 +86,17 @@         font = temp,         font' = temp,         inner = temp,+        innerProperties = [],+        innerParent = trace ("Parent not overriden upon " +++            "buffering inner properties for length resolution!") temp,         gridStyles = temp,         cellStyles = temp,         inlineStyles = temp,         captionBelow = False,-        pageOptions = PageOptions 0 0 2 2+        pageOptions = PageOptions 0 0 2 2,+        paragraphOptions = defaultParagraphOptions {+            paragraphAlignment = AlignStart+        }       }     inherit parent = CSSBox {         boxSizing = boxSizing parent,@@ -90,11 +105,14 @@         font = inherit $ font parent,         font' = inherit $ font' parent,         inner = inherit $ inner parent,+        innerProperties = [],+        innerParent = inner parent,         gridStyles = inherit $ gridStyles parent,         cellStyles = inherit $ cellStyles parent,         inlineStyles = inherit $ inlineStyles parent,         captionBelow = captionBelow parent,-        pageOptions = pageOptions parent+        pageOptions = pageOptions parent,+        paragraphOptions = paragraphOptions parent       }     priority self = concat [x font, x font', x gridStyles, x cellStyles, x inner]       where x getter = priority $ getter self@@ -259,6 +277,12 @@         Just b { gridStyles = grid' }     longhand a b c d | Just cell' <- longhand (cellStyles a) (cellStyles b) c d =         Just b { cellStyles = cell' }+    longhand a b c d+        | (d', _:_)<-testLengthProp d, Just _<-longhand (inner a) (inner b) c d' =+            Just b {+                innerProperties = (c, d):innerProperties b,+                innerParent = inner a+            }     longhand a b c d | Just inner' <- longhand (inner a) (inner b) c d = Just b {         inner = inner'       }@@ -274,6 +298,28 @@             }}       where p x = Numbered x Nothing +    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "initial"] =+        Just self { paragraphOptions = o { paragraphAlignment = AlignStart } }+    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "start"] =+        Just self { paragraphOptions = o { paragraphAlignment = AlignStart } }+    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "end"] =+        Just self { paragraphOptions = o { paragraphAlignment = AlignEnd } }+    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "left"] =+        Just self { paragraphOptions = o { paragraphAlignment = AlignLeft } }+    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "right"] =+        Just self { paragraphOptions = o { paragraphAlignment = AlignRight } }+    longhand _ self@CSSBox {paragraphOptions=o} "text-align" [Ident "center"] =+        Just self { paragraphOptions = o { paragraphAlignment = AlignCentreH } }+    -- text-align: justify is unimplemented.+    longhand p self@CSSBox { paragraphOptions = o } "text-align"+            [Ident "match-parent"] = case paragraphAlignment$paragraphOptions p of+        AlignStart | DirLTR <- direction p -> ret AlignLeft+        AlignStart | DirRTL <- direction p -> ret AlignRight+        AlignEnd | DirLTR <- direction p -> ret AlignRight+        AlignEnd | DirRTL <- direction p -> ret AlignLeft+        x -> ret x+      where ret x = Just self { paragraphOptions = o { paragraphAlignment = x } }+     longhand _ _ _ _ = Nothing      shorthand self "font" toks = case parseOperands toks of@@ -317,88 +363,28 @@                 [("border-top-width", top), ("border-right-width", right),                  ("border-bottom-width", bottom), ("border-left-width", left)]       where x = parseOperands toks-    -- Define other border shorthands here to properly handle border-widths-    shorthand self "border" toks = parseUnorderedShorthand self [-        "border-color", "border-style", "border-width"] toks-    shorthand self "border-top" toks = parseUnorderedShorthand self [-        "border-top-color", "border-top-style", "border-top-width"] toks-    shorthand self "border-right" toks = parseUnorderedShorthand self [-        "border-right-color", "border-right-style", "border-right-width"] toks-    shorthand self "border-bottom" toks = parseUnorderedShorthand self [-        "border-bottom-color", "border-bottom-style", "border-bottom-width"] toks-    shorthand self "border-left" toks = parseUnorderedShorthand self [-        "border-left-color", "border-left-style", "border-left-width"] toks-    shorthand self "border-inline" toks = parseUnorderedShorthand self [-        "border-inline-color", "border-inline-style", "border-inline-width"] toks-    shorthand self "border-inline-start" toks = parseUnorderedShorthand self [-        "border-inline-start-color", "border-inline-start-style",-        "border-inline-start-width"] toks-    shorthand self "border-inline-end" toks = parseUnorderedShorthand self [-        "border-inline-end-color", "border-inline-end-style",-        "border-inline-end-width"] toks-    shorthand self "border-block" toks = parseUnorderedShorthand self [-        "border-block-color", "border-block-style", "border-block-width"] toks-    shorthand self "border-block-start" toks = parseUnorderedShorthand self [-        "border-block-start-color", "border-block-start-style",-        "border-block-start-width"] toks-    shorthand self "border-block-end" toks = parseUnorderedShorthand self [-        "border-block-end-color", "border-block-end-style",-        "border-block-end-width"] toks-    shorthand self "border-color" toks-        | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x,-            all (validProp self "border-top-color") x =-                [("border-top-color", top), ("border-right-color", right),-                 ("border-bottom-color", bottom), ("border-left-color", left)]-      where x = parseOperands toks-    shorthand self "border-style" toks-        | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x,-            all (validProp self "border-top-style") x =-                [("border-top-style", top), ("border-right-style", right),-                 ("border-bottom-style", bottom), ("border-left-style", left)]-      where x = parseOperands toks-    shorthand self "border-width" toks-        | length x > 0 && length x <= 4, (top:right:bottom:left:_) <- cycle x,-            all (validProp self "border-top-width") x =-                [("border-top-width", top), ("border-right-width", right),-                 ("border-bottom-width", bottom), ("border-left-width", left)]-      where x = parseOperands toks-    shorthand self "border-inline-color" toks-        | length x > 0 && length x <= 2, (s:e:_) <- cycle x,-            all (validProp self "border-inline-start-color") x =-                [("border-inline-start-color", s), ("border-inline-end-color", e)]-      where x = parseOperands toks-    shorthand self "border-inline-style" toks-        | length x > 0 && length x <= 2, (s:e:_) <- cycle x,-            all (validProp self "border-inline-start-style") x =-                [("border-inline-start-style", s), ("border-inline-end-style", e)]-      where x = parseOperands toks-    shorthand self "border-inline-width" toks-        | length x > 0 && length x <= 2, (s:e:_) <- cycle x,-            all (validProp self "border-inline-start-width") x =-                [("border-inline-start-width", s), ("border-inline-end-style", e)]-      where x = parseOperands toks-    shorthand self "border-block-color" toks-        | length x > 0 && length x <= 2, (s:e:_) <- cycle x,-            all (validProp self "border-block-start-color") x =-                [("border-block-start-color", s), ("border-block-end-color", e)]-      where x = parseOperands toks-    shorthand self "border-block-style" toks-        | length x > 0 && length x <= 2, (s:e:_) <- cycle x,-            all (validProp self "border-block-start-style") x =-                [("border-block-start-style", s), ("border-block-end-style", e)]-      where x = parseOperands toks-    shorthand self "border-block-width" toks-        | length x > 0 && length x <= 2, (s:e:_) <- cycle x,-            all (validProp self "border-block-start-width") x =-                [("border-block-start-width", s), ("border-block-end-width", e)]-      where x = parseOperands toks -    shorthand self k v | Just _ <- longhand self self k v = [(k, v)]     shorthand self k v | ret@(_:_) <- shorthand (font self) k v = ret     shorthand self k v | ret@(_:_) <- shorthand (font' self) k v = ret     shorthand self k v | ret@(_:_) <- shorthand (inlineStyles self) k v = ret     shorthand self k v | ret@(_:_) <- shorthand (gridStyles self) k v = ret     shorthand self k v | ret@(_:_) <- shorthand (cellStyles self) k v = ret-    shorthand self k v = shorthand (inner self) k v+    shorthand self k v | ret@(_:_) <- shorthand (inner self) k v = ret+    shorthand self k v+        | (v', ls)<-testLengthProp v, ret@(_:_)<-shorthand (inner self) k v' =+            [(key, map (restore ls) value) | (key, value) <- ret]+      where+        restore ls (Dimension _ (NVInteger x) "px") | x' < length ls = ls !! x'+          where x' = fromInteger x+        restore _ ret = ret+    shorthand self k v | Just _ <- longhand self self k v = [(k, v)]+        | otherwise = []  validProp self key value = isJust $ longhand self self key value++testLengthProp (tok@(Dimension _ _ unit):toks) | unit `elem` units =+    let (toks', lengths) = testLengthProp toks+    in (Dimension "" (NVInteger $ toInteger $ succ $ length lengths) "px":toks',+        tok:lengths)+testLengthProp (tok:toks) = let (toks',ls) = testLengthProp toks in (tok:toks',ls)+testLengthProp [] = ([], [])

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings, DeriveGeneric #-} -- | Sizes grid cells & positions elements to them. module Graphics.Layout.Grid(Grid(..), Track(..), GridItem(..), GridItem'(..), Alignment(..),         buildTrack, buildGrid, setCellBox, enumerate, gridItemBox, cellSize,@@ -11,6 +11,8 @@ import Graphics.Layout.Box as B  import Debug.Trace (trace)+import GHC.Generics (Generic)+import Control.DeepSeq (NFData)  -- | An element which positions it's children within a grid. type Grid m n = Size (Track m) (Track n)@@ -40,9 +42,11 @@     minSize :: Double,     -- | The maximum aount of space to allocate to this child.     natSize :: Double-}+} deriving (Read, Show, Ord, Eq, Generic)+instance NFData GridItem' -- | How to redistribute excess space.-data Alignment = Start | Mid | End+data Alignment = Start | Mid | End deriving (Read, Show, Enum, Ord, Eq, Generic)+instance NFData Alignment  -- | Constructs a track with default (to-be-computed) values & given cell sizes. buildTrack :: CastDouble x => [Either x Double] -> Track x

@@ -8,7 +8,8 @@ import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..),                                 Fragment(..), ParagraphLayout(..), AncestorBox(..),                                 InnerNode(..), Box(..), RootNode(..),-                                layoutRich, boxSpacing, BoxSpacing(..))+                                layoutRich, boxSpacing, BoxSpacing(..),+                                activateBoxSpacing, paragraphSafeWidth) import Data.Text.ParagraphLayout.Rect (Rect(..),                                 width, height, x_max, x_min, y_min, y_max) import Data.Int (Int32)@@ -31,12 +32,12 @@ -- | Compute minimum width & height for some richtext. inlineMin :: (CastDouble x, CastDouble y) =>         Paragraph (a, PaddedBox x y, c) -> Size x y-inlineMin self = Size (c $ width rect) (c $ height rect)-    where rect = layoutRich' self 0+inlineMin = layoutSize' . flip layoutRich' 0 -- | Compute width & height of some richtext at configured width. inlineSize :: (CastDouble x, CastDouble y) =>         Paragraph (a, PaddedBox x y, c) -> Size x y-inlineSize self = layoutSize $ layoutRich $ lowerSpacing self+inlineSize self@(Paragraph _ _ _ opts) =+    layoutSize' . layoutRich' self $ paragraphMaxWidth opts -- | Retrieve children out of some richtext, -- associating given userdata with them. inlineChildren :: (CastDouble x, CastDouble y, Eq x, Eq y, Eq a, Eq c) =>@@ -45,17 +46,20 @@  -- | Retrieve a laid-out paragraph's rect & convert to CatTrap types. layoutSize :: (CastDouble x, CastDouble y) => ParagraphLayout a -> Size x y-layoutSize self = Size (c $ width r) (c $ height r)-  where r = paragraphRect self+layoutSize = layoutSize' . paragraphRect+layoutSize' r = Size (c $ width r) (c $ height r) -- | Retrieve a laid-out paragraph's children & associate with given userdata. layoutChildren :: Eq a => ParagraphLayout a -> [FragmentTree a] layoutChildren self = reconstructTree self  -- | Layout a paragraph at given width & retrieve resulting rect.+-- LEGACY. layoutRich' :: (CastDouble m, CastDouble n) =>         Paragraph (a, PaddedBox m n, c) -> Int32 -> Rect Int32-layoutRich' (Paragraph a b c d) width = paragraphRect $ layoutRich $-    lowerSpacing $ Paragraph a b c d { paragraphMaxWidth = width }+layoutRich' (Paragraph a b c d) width =+    (paragraphRect layout) { x_size = paragraphSafeWidth layout}+  where+    layout = layoutRich$lowerSpacing$Paragraph a b c d {paragraphMaxWidth=width}  -- | Copy surrounding whitespace into Balkon properties. lowerSpacing :: (CastDouble m, CastDouble n) =>@@ -63,9 +67,9 @@ lowerSpacing (Paragraph a b (RootBox c) d) = Paragraph a b (RootBox $ inner c) d   where     inner (Box childs opts) = flip Box opts $ map inner' childs-    inner' (InlineBox e@(_, f, _) child opts) = InlineBox e (inner child) opts {-            boxSpacing = BoxSpacingLeftRight (leftSpace box) (rightSpace box)-        }+    inner' (InlineBox e@(_, f, _) child opts) = InlineBox e (inner child) $+        flip activateBoxSpacing opts $+            BoxSpacingLeftRight (leftSpace box) (rightSpace box)       where box = mapX' unscale $ mapY' unscale f     inner' self@(TextSequence _ _) = self @@ -87,7 +91,7 @@ -- | Apply an operation to the 2nd field of a laid-out paragraph's userdata, -- for it's entire subtree. layoutMap :: (b -> b') -> ParagraphLayout (a, b, c) -> ParagraphLayout (a, b', c)-layoutMap cb (ParagraphLayout a b) = ParagraphLayout a $ map inner b+layoutMap cb (ParagraphLayout a b c) = ParagraphLayout a b $ map inner c   where     inner self@Fragment { fragmentUserData = (a, b, c) } = self {         fragmentUserData = (a, cb b, c),@@ -179,8 +183,8 @@   where     pos = (x + hbScale (x_min rect), y + hbScale (y_min rect))     rect = treeRect self-positionTree (x, y) self@(Leaf (Fragment (a, b, c) d _ f g h)) =-    Leaf (Fragment (a, b, (pos, c)) d [] f g h)+positionTree (x, y) self@(Leaf (Fragment (a, b, c) d _ f g h i)) =+    Leaf (Fragment (a, b, (pos, c)) d [] f g h i)   where     pos = (x + hbScale (x_min rect), y + hbScale (y_min rect))     rect = treeRect self

@@ -0,0 +1,198 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}+module Main where++import System.Environment (getArgs)+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Maybe (fromJust, fromMaybe)+import qualified Data.Text as Txt+import qualified Data.ByteString as BS+import System.Directory (getCurrentDirectory)+import qualified System.Directory as Dir++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 Network.URI.Fetch.XML (Page(..), fetchDocument, applyCSScharset)+import Network.URI.Fetch (newSession, fetchURL)+import Network.URI.Charset (charsets)+import Network.URI (URI(..), nullURI, parseURIReference)+import Data.FileEmbed (makeRelativeToProject, embedStringFile)+import Data.HTML2CSS (el2stylist)++import Text.XML as X (Document(..), Element(..), Node(..), Prologue(..))+import Stylist.Tree (StyleTree(..), preorder, treeMap)+import Stylist (PropertyParser(..), cssPriorityAgent, cssPriorityUser)+import qualified Data.CSS.Style as Style+import qualified Data.CSS.Syntax.StyleSheet as CSS+import qualified Data.CSS.Preprocessor.Text as CSSTxt+import Data.CSS.Preprocessor.Conditions as CSSCond+        (ConditionalStyles, conditionalStyles, loadImports, Datum(..), resolve)+import qualified Data.CSS.Preprocessor.PsuedoClasses as CSSPseudo++import Control.Concurrent.MVar (putMVar, newEmptyMVar, tryReadMVar)+import Control.Concurrent (forkIO)+import Control.DeepSeq (NFData(..), ($!!))++import SDL hiding (rotate)+import Foreign.C.Types (CInt)+import Data.Function (fix)+import Control.Monad (unless)+import qualified Graphics.Text.Font.Choose as FC++initReferer :: IO (Page (CSSCond.ConditionalStyles (CSSBox Nil)))+initReferer = do+    cwd <- getCurrentDirectory+    return $ Page {+        -- Default to URIs being relative to CWD.+        pageURL = URI {uriScheme = "file:", uriPath = cwd,+            uriAuthority = Nothing, uriQuery = "", uriFragment = ""},+        -- Blank values:+        css = conditionalStyles nullURI "temp",+        domain = "temp",+        html = Document {+            documentPrologue = Prologue [] Nothing [],+            documentRoot = Element "temp" M.empty [],+            documentEpilogue = []+        },+        pageTitle = "", pageMIME = "", apps = [],+        backStack = [], forwardStack = [], visitedURLs = S.empty,+        initCSS = conditionalStyles,+        appName = "cattrap"+    }++stylize' style = preorder inner+  where+    inner parent _ el = Style.cascade style el [] $+            Style.inherit $ fromMaybe Style.temp parent++resolveCSS manager page = do+    let agentStyle = cssPriorityAgent (css page) `CSS.parse`+            $(makeRelativeToProject "app/useragent.css" >>= embedStringFile)+    userStyle <- loadUserStyles agentStyle+    CSSCond.loadImports loadURL lowerVars lowerToks userStyle []+  where+    loadURL url = do+        response <- fetchURL manager ["text/css"] url+        let charsets' = map Txt.unpack charsets+        return $ case response of+            ("text/css", Left text) -> text+            ("text/css", Right bytes) -> applyCSScharset charsets' $ BS.toStrict bytes+            (_, _) -> ""++loadUserStyles styles = do+    dir <- Dir.getXdgDirectory Dir.XdgConfig "rhapsode"+    exists <- Dir.doesDirectoryExist dir+    loadDirectory dir exists+  where+    loadDirectory _ False = return styles+    loadDirectory dir True = do+        files <- Dir.listDirectory dir+        loadFiles (cssPriorityUser styles) files+    loadFiles style (file:files) = do+        source <- readFile file+        CSS.parse style (Txt.pack source) `loadFiles` files+    loadFiles style [] = return style+-- FIXME: Support more media queries!+resolve' = CSSCond.resolve lowerVars lowerToks+lowerVars _ = CSSCond.B False+lowerToks _ = CSSCond.B False++main :: IO ()+main = do+    FC.init+    SDL.initializeAll++    let wcfg = defaultWindow {+            windowInitialSize = V2 1280 480,+            -- Simplify moving layout/download out-of-thread+            windowResizable = False+          }+    w <- createWindow "CatTrap" wcfg+    renderer <- createRenderer w (-1) defaultRenderer++    args <- getArgs+    let url = case args of+            (url:_) -> url+            [] -> "https://git.argonaut-constellation.org/~alcinnz/CatTrap"+    sess <- newSession+    ref <- initReferer+    xml <- fetchDocument sess ref $ fromMaybe nullURI $ parseURIReference url+    let pseudoFilter = CSSPseudo.htmlPsuedoFilter Style.queryableStyleSheet+    css' <- resolveCSS sess xml+    let css = CSSPseudo.inner $ resolve' pseudoFilter css'+    let styles = CSSTxt.resolve $ treeMap Style.innerParser $+            stylize' css $ el2stylist $ X.documentRoot $ html xml+    let layout = finalizeCSS' placeholderFont styles+    V2 x y <- get $ windowSize w+    pages' <- forkCompute $ boxLayout zeroBox {+            B.size = B.Size (fromIntegral x) (fromIntegral y)+          } layout False++    fix $ \loop -> do+        events <- fmap eventPayload <$> pollEvents+        rendererDrawColor renderer $= V4 255 255 255 255+        clear renderer++        pages <- tryReadMVar pages'+        case pages of+            Just (display:_) -> renderDisplay renderer display+            _ -> return ()++        present renderer+        unless (QuitEvent `elem` events) loop+    SDL.quit+    -- FC.fini -- FIXME: Need to free all Haskell data before freeing FontConfig's++data Nil = Nil deriving Eq+instance PropertyParser Nil where+    temp = Nil+    inherit _ = Nil+    longhand _ _ _ _ = Nothing+instance NFData Nil where rnf Nil = ()+++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++forkCompute dat = do+    ret <- newEmptyMVar+    forkIO $ putMVar ret $!! dat+    return ret

@@ -0,0 +1,69 @@+module Main where++import Text.HTML.DOM as HTML+import Text.XML as X+import Data.HTML2CSS (html2css, el2stylist)+import Network.URI (nullURI)++import Data.CSS.Preprocessor.Conditions as CSSCond+import qualified Data.CSS.Preprocessor.PsuedoClasses as CSSPseudo+import qualified Data.CSS.Style as Style+import Stylist.Tree (StyleTree(..), preorder, treeMap)+import qualified Data.CSS.Preprocessor.Text as CSSTxt+import Data.Maybe (fromMaybe)++import Graphics.Layout.CSS.Font (placeholderFont)+import Graphics.Layout.CSS (finalizeCSS', CSSBox)+import Graphics.Layout (LayoutItem, boxLayout)+import Graphics.Layout.Box (Length, Size(..), PaddedBox(..), zeroBox)++import Control.Exception (evaluate)+import qualified Graphics.Text.Font.Choose as FC++import Control.Concurrent.MVar (putMVar, newEmptyMVar, readMVar)+import Control.Concurrent (forkIO)+import Control.DeepSeq (NFData(..), ($!!))+--import System.Mem (performGC)++resolve' = CSSCond.resolve lowerVars lowerToks+lowerVars _ = CSSCond.B False+lowerToks _ = CSSCond.B False++stylize' style = preorder inner+  where+    inner parent _ el = Style.cascade style el [] $+            Style.inherit $ fromMaybe Style.temp parent++main :: IO ()+main = do+    FC.init+    doc <- HTML.readFile "test.html"+    let css' :: CSSCond.ConditionalStyles (Style.VarParser (CSSTxt.TextStyle+                (CSSBox Nil)))+        css' = html2css doc nullURI $ CSSCond.conditionalStyles nullURI "temp"+    css' `seq` print "Parsed page with CSS!"+    let pseudoFilter = CSSPseudo.htmlPsuedoFilter Style.queryableStyleSheet+    let css = CSSPseudo.inner $ resolve' pseudoFilter css'+    let styles = CSSTxt.resolve $ treeMap Style.innerParser $+            stylize' css $ el2stylist $ X.documentRoot doc+    styles `seq` print "Styled page!"+    let layout :: LayoutItem Length Length Nil+        layout = finalizeCSS' placeholderFont styles+    layout `seq` print "Laying out page!"+    res <- forkCompute $ boxLayout zeroBox { size = Size 1280 480 } layout False+    readMVar res+    --performGC+    --FC.fini -- FIXME: GC still left FontConfig references...+    return ()++data Nil = Nil deriving Eq+instance Style.PropertyParser Nil where+    temp = Nil+    inherit _ = Nil+    longhand _ _ _ _ = Nothing+instance NFData Nil where rnf Nil = ()++forkCompute dat = do+    ret <- newEmptyMVar+    forkIO $ putMVar ret $!! dat+    return ret

@@ -1,5 +1,7 @@+{-# 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)@@ -17,19 +19,23 @@ 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)+import SDL hiding (rotate)+import Foreign.C.Types (CInt)+import Data.Function (fix)+import Control.Monad (unless)  main :: IO () main = do-    (progname, args) <- getArgsAndInitialize+    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"@@ -37,30 +43,19 @@     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+    fix $ \loop -> do+        events <- fmap eventPayload <$> pollEvents+        rendererDrawColor renderer $= V4 255 255 255 255+        clear renderer -    displayCallback $= do-        clear [ ColorBuffer ]-        Size x y <- get windowSize+        V2 x y <- get $ windowSize w         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 renderer display -        renderDisplay shader display-        flush-    mainLoop+        present renderer+        unless (QuitEvent `elem` events) loop  xml2styles :: CSSBox Nil -> X.Element -> StyleTree (CSSBox Nil) xml2styles parent el = StyleTree {@@ -78,138 +73,38 @@     inherit _ = Nil     longhand _ _ _ _ = Nothing -renderDisplay :: Eq a => GLuint -> LayoutItem Double Double ((Double, Double), a)+renderDisplay :: Renderer -> LayoutItem Double Double ((Double, Double), Nil)         -> IO ()-renderDisplay shader display = do+renderDisplay renderer 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)+    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 shader) $ layoutGetChilds display+    mapM (renderDisplay renderer) $ 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+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)) -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; }"-  ]+c :: (Enum a, Enum b) => a -> b+c = toEnum . fromEnum

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                cattrap-version:             0.2.0.0+version:             0.3.0.0 synopsis:            Lays out boxes according to the CSS Box Model. description:         Computes where to place e.g. images, paragraphs, containers, tables, etc onscreen given desired amounts of whitespace. homepage:            https://argonaut-constellation.org/@@ -29,12 +29,12 @@                         Graphics.Layout.Inline, Graphics.Layout.Inline.CSS   other-modules:        Graphics.Layout.CSS.Parse   -- other-extensions:-  build-depends:       base >=4.12 && <4.16, containers,-                        css-syntax, scientific, text,+  build-depends:       base >=4.12 && <5, containers, parallel >= 3,+                        css-syntax, scientific, text, deepseq,                         stylist-traits >= 0.1.3.0 && < 1,-                        fontconfig-pure >= 0.2 && < 0.3,+                        fontconfig-pure >= 0.2 && < 0.5,                         harfbuzz-pure >= 1.0.3.2 && < 1.1, bytestring,-                        balkon >= 1.1 && <2, unordered-containers+                        balkon >= 1.2 && <2, unordered-containers   -- hs-source-dirs:   default-language:    Haskell2010   ghc-options:         -Wincomplete-patterns@@ -43,7 +43,24 @@   main-is:             Main.hs   -- other-modules:   -- other-extensions:-  build-depends:       base >=4.12 && <4.16, cattrap, xml, text, css-syntax, stylist-traits, GLUT, gl+  build-depends:       base >=4.12 && <5, cattrap, text, css-syntax, xml, stylist-traits, sdl2 >= 2.5.4+  hs-source-dirs:      app+  default-language:    Haskell2010++executable cattrap-argonaut+  main-is:             Integration.hs+  -- other-modules:+  -- other-extensions:+  build-depends:       base >=4.12 && <5, cattrap, text>=2.0.2, css-syntax, stylist-traits, stylist>=2.7.0.1, hurl-xml, hurl, sdl2 >= 2.5.4, containers, network-uri, xml-conduit, directory, xml-conduit-stylist, bytestring, file-embed, deepseq, fontconfig-pure+  hs-source-dirs:      app+  default-language:    Haskell2010+  ghc-options:	-threaded++executable cattrap-stylist+  main-is:             Integration2.hs+  -- other-modules:+  -- other-extensions:+  build-depends:       base >=4.12 && <5, cattrap, text>=2.0.2, css-syntax, stylist-traits, stylist>=2.7.0.1, network-uri, html-conduit, xml-conduit, xml-conduit-stylist, deepseq, fontconfig-pure   hs-source-dirs:      app   default-language:    Haskell2010