From 156ac2ae7bf338961179514eb0e9e4beb02f50a6 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 13 Oct 2023 13:36:38 +1300 Subject: [PATCH] Segfault/performance fixes. --- Graphics/Layout.hs | 5 +++++ Graphics/Layout/Box.hs | 17 +++++++++++------ app/Integration.hs | 9 ++++++++- cattrap.cabal | 14 +++++++++++--- 4 files changed, 35 insertions(+), 10 deletions(-) diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs index cccfc37..1d646f0 100644 --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -15,6 +15,7 @@ import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..), 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 @@ -54,6 +55,10 @@ data LayoutItem m n x = 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 diff --git a/Graphics/Layout/Box.hs b/Graphics/Layout/Box.hs index 6314dfe..cea83b0 100644 --- a/Graphics/Layout/Box.hs +++ b/Graphics/Layout/Box.hs @@ -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,12 +8,14 @@ module Graphics.Layout.Box(Border(..), mapX, mapY, leftSpace, rightSpace, topSpace, bottomSpace, hSpace, vSpace, Length(..), mapAuto, lowerLength, Zero(..), CastDouble(..)) where -import Debug.Trace +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. @@ -23,7 +25,8 @@ mapY cb self = self { top = cb $ top self, bottom = cb $ bottom self } -- | 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) @@ -47,7 +50,8 @@ data PaddedBox m n = PaddedBox { 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 { @@ -126,7 +130,8 @@ data Length = Pixels Double -- ^ Absolute number of device pixels. | 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 diff --git a/app/Integration.hs b/app/Integration.hs index ee29ae4..7d68d53 100644 --- a/app/Integration.hs +++ b/app/Integration.hs @@ -36,11 +36,13 @@ 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 @@ -102,6 +104,7 @@ lowerToks _ = CSSCond.B False main :: IO () main = do + FC.init SDL.initializeAll let wcfg = defaultWindow { @@ -142,12 +145,16 @@ main = do present renderer unless (QuitEvent `elem` events) loop + SDL.quit + FC.fini 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 () @@ -187,5 +194,5 @@ c = toEnum . fromEnum forkCompute dat = do ret <- newEmptyMVar - forkIO $ putMVar ret $! dat + forkIO $ putMVar ret $!! dat return ret diff --git a/cattrap.cabal b/cattrap.cabal index bcfad62..760c408 100644 --- a/cattrap.cabal +++ b/cattrap.cabal @@ -30,9 +30,9 @@ library other-modules: Graphics.Layout.CSS.Parse -- other-extensions: build-depends: base >=4.12 && <5, containers, parallel >= 3, - css-syntax, scientific, text, + 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.2 && <2, unordered-containers -- hs-source-dirs: @@ -51,11 +51,19 @@ 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 + 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 + test-suite test-cattrap hs-source-dirs: test default-language: Haskell2010 -- 2.30.2