~alcinnz/CatTrap: Performance optimizations: Concurrency, & move download/styling/layout to out-of-thread.

4 files changed, 117 insertions(+), 56 deletions(-)

M Graphics/Layout.hs
M Graphics/Layout/Box.hs
M app/Integration.hs
M cattrap.cabal

M Graphics/Layout.hs => Graphics/Layout.hs +22 -19

@@ 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

M Graphics/Layout/Box.hs => Graphics/Layout/Box.hs +2 -0

@@ 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

M app/Integration.hs => app/Integration.hs +83 -28

@@ 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

M cattrap.cabal => cattrap.cabal +10 -9

@@ 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