From 437eeb7178171d6b76db51305cc6a5e45ba8e9b2 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 3 Jul 2023 13:12:42 +1200 Subject: [PATCH] Draft integration test against Stylist & HURL, shelve due to incomplete Text v2 transition. --- app/Integration.hs | 136 +++++++++++++++++++++++++++++++++++++++++++++ cattrap.cabal | 10 +++- 2 files changed, 145 insertions(+), 1 deletion(-) create mode 100644 app/Integration.hs diff --git a/app/Integration.hs b/app/Integration.hs new file mode 100644 index 0000000..b6ff81f --- /dev/null +++ b/app/Integration.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import System.Environment (getArgs) +import qualified Data.Map as M +import Data.Maybe (fromJust, fromMaybe) +import qualified Data.Text as Txt + +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 Stylist.Tree (StyleTree(..)) +import Stylist (PropertyParser(..)) +import Network.URI.Fetch.XML (Page(..), fetchDocument) +import Network.URI.Fetch (newSession) + +import SDL hiding (rotate) +import Foreign.C.Types (CInt) +import Data.Function (fix) +import Control.Monad (unless) + +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 = M.empty, + initCSS = conditionalStyles, + appName = "cattrap" + } + +stylize' style = preorder inner + where + inner parent _ el = Style.cascade style el [] $ + Style.inherit $ fromMaybe Style.temp parent + +main :: IO () +main = do + SDL.initializeAll + + let wcfg = defaultWindow { + windowInitialSize = V2 640 480, + windowResizable = True + } + 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" + sess <- newSession + let xml = fetchDocument sess initReferer $ parseURIReference url + let styles = CSSTxt.resolve $ treeMap Style.innerParser $ + stylize' (css xml) $ el2stylist $ html xml + let layout = finalizeCSS' placeholderFont styles + + 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 + + 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 + inherit _ = Nil + longhand _ _ _ _ = Nothing + +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 diff --git a/cattrap.cabal b/cattrap.cabal index 33ea32d..c1cf44a 100644 --- a/cattrap.cabal +++ b/cattrap.cabal @@ -43,10 +43,18 @@ executable cattrap main-is: Main.hs -- other-modules: -- other-extensions: - build-depends: base >=4.12 && <4.16, cattrap, xml, text, css-syntax, stylist-traits, sdl2 >= 2.5.4 + build-depends: base >=4.12 && <4.16, 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 + test-suite test-cattrap hs-source-dirs: test default-language: Haskell2010 -- 2.30.2