From 9478d6300bcae4f6d5c29d7777a7544303358dba Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 28 Sep 2023 10:26:36 +1300 Subject: [PATCH] Performance optimizations: Concurrency, & move download/styling/layout to out-of-thread. --- Graphics/Layout.hs | 41 ++++++++------- Graphics/Layout/Box.hs | 2 + app/Integration.hs | 111 ++++++++++++++++++++++++++++++----------- cattrap.cabal | 19 +++---- 4 files changed, 117 insertions(+), 56 deletions(-) diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs index fd17f7d..cccfc37 100644 --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -14,6 +14,7 @@ import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..), ParagraphLayout(..), layoutRich) import Data.Text.ParagraphLayout (paginate, PageContinuity(..), PageOptions(..)) import Stylist (PropertyParser(temp)) +import Control.Parallel.Strategies import Graphics.Layout.Box as B import Graphics.Layout.Grid as G @@ -99,7 +100,7 @@ boxMinWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs' 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 +109,7 @@ boxMinWidth parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' ce 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 @@ -126,7 +127,7 @@ boxNatWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs' 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 +136,7 @@ boxNatWidth parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' ce 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 @@ -149,13 +150,13 @@ boxNatWidth _ self@(LayoutSpan _) = self boxMaxWidth :: CastDouble 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 } @@ -169,14 +170,14 @@ boxWidth :: (Zero y, CastDouble y) => PaddedBox b Double -> LayoutItem y Length 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 +208,13 @@ boxNatHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs' 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 +225,12 @@ boxNatHeight parent self@(LayoutSpan _) = self 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 +248,13 @@ boxMaxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> 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 +270,7 @@ boxMaxHeight parent (LayoutSpan self') = LayoutSpan self' 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 +278,7 @@ boxHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs' 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 +352,12 @@ boxPosition :: (PropertyParser x, Eq x) => (Double, Double) -> 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 +365,7 @@ boxPosition pos@(x, y) (LayoutInline val self paging) = 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 +393,5 @@ glyphsPerFont (LayoutSpan _ font self) = (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' = parMap rseq diff --git a/Graphics/Layout/Box.hs b/Graphics/Layout/Box.hs index f7aaaa6..6314dfe 100644 --- a/Graphics/Layout/Box.hs +++ b/Graphics/Layout/Box.hs @@ -8,6 +8,8 @@ module Graphics.Layout.Box(Border(..), mapX, mapY, leftSpace, rightSpace, topSpace, bottomSpace, hSpace, vSpace, Length(..), mapAuto, lowerLength, Zero(..), CastDouble(..)) where +import Debug.Trace + -- | Amount of space surrounding the box. data Border m n = Border { top :: m, bottom :: m, left :: n, right :: n diff --git a/app/Integration.hs b/app/Integration.hs index b6ff81f..ee29ae4 100644 --- a/app/Integration.hs +++ b/app/Integration.hs @@ -1,10 +1,14 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# 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) @@ -13,16 +17,32 @@ import Graphics.Layout (LayoutItem, boxLayout, import Graphics.Layout.Box (zeroBox) import qualified Graphics.Layout.Box as B -import Stylist.Tree (StyleTree(..)) -import Stylist (PropertyParser(..)) -import Network.URI.Fetch.XML (Page(..), fetchDocument) -import Network.URI.Fetch (newSession) +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 SDL hiding (rotate) import Foreign.C.Types (CInt) import Data.Function (fix) import Control.Monad (unless) +initReferer :: IO (Page (CSSCond.ConditionalStyles (CSSBox Nil))) initReferer = do cwd <- getCurrentDirectory return $ Page { @@ -38,7 +58,7 @@ initReferer = do documentEpilogue = [] }, pageTitle = "", pageMIME = "", apps = [], - backStack = [], forwardStack = [], visitedURLs = M.empty, + backStack = [], forwardStack = [], visitedURLs = S.empty, initCSS = conditionalStyles, appName = "cattrap" } @@ -48,51 +68,81 @@ stylize' style = preorder inner 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 SDL.initializeAll let wcfg = defaultWindow { - windowInitialSize = V2 640 480, - windowResizable = True + windowInitialSize = V2 1280 480, + -- Simplify moving layout/download out-of-thread + windowResizable = False } w <- createWindow "CatTrap" wcfg renderer <- createRenderer w (-1) defaultRenderer args <- getArgs - url <- readFile $ case args of - (url:_) -> url - [] -> "https://git.argonaut-constellation.org/~alcinnz/CatTrap" + let url = case args of + (url:_) -> url + [] -> "https://git.argonaut-constellation.org/~alcinnz/CatTrap" sess <- newSession - let xml = fetchDocument sess initReferer $ parseURIReference url + 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 xml) $ el2stylist $ html xml + 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 - V2 x y <- get $ windowSize w - let (display:_) = boxLayout zeroBox { - B.size = B.Size (fromIntegral x) (fromIntegral y) - } layout False - renderDisplay renderer display + pages <- tryReadMVar pages' + case pages of + Just (display:_) -> renderDisplay renderer display + _ -> return () present renderer unless (QuitEvent `elem` events) loop -xml2styles :: CSSBox Nil -> X.Element -> StyleTree (CSSBox Nil) -xml2styles parent el = StyleTree { - style = self', - children = [xml2styles self' child | X.Elem child <- X.elContent el] - } where self' = foldl (applyStyle parent) temp $ X.elAttribs el - -applyStyle parent style (X.Attr (X.QName name _ _) val) = - fromMaybe style $ longhand parent style (Txt.pack name) $ - filter (/= Whitespace) $ tokenize $ Txt.pack val - data Nil = Nil deriving Eq instance PropertyParser Nil where temp = Nil @@ -134,3 +184,8 @@ drawBox renderer x y width height = do c :: (Enum a, Enum b) => a -> b c = toEnum . fromEnum + +forkCompute dat = do + ret <- newEmptyMVar + forkIO $ putMVar ret $! dat + return ret diff --git a/cattrap.cabal b/cattrap.cabal index c1cf44a..bcfad62 100644 --- a/cattrap.cabal +++ b/cattrap.cabal @@ -29,7 +29,7 @@ library Graphics.Layout.Inline, Graphics.Layout.Inline.CSS other-modules: Graphics.Layout.CSS.Parse -- other-extensions: - build-depends: base >=4.12 && <4.16, containers, + build-depends: base >=4.12 && <5, containers, parallel >= 3, css-syntax, scientific, text, stylist-traits >= 0.1.3.0 && < 1, fontconfig-pure >= 0.2 && < 0.3, @@ -43,17 +43,18 @@ executable cattrap main-is: Main.hs -- other-modules: -- other-extensions: - build-depends: base >=4.12 && <4.16, cattrap, text, css-syntax, xml, stylist-traits, sdl2 >= 2.5.4 + 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 && <4.16, cattrap, text, css-syntax, stylist-traits, stylist, hurl-xml, hurl, 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 + hs-source-dirs: app + default-language: Haskell2010 + ghc-options: -threaded test-suite test-cattrap hs-source-dirs: test -- 2.30.2