2 files changed, 145 insertions(+), 1 deletions(-)

A app/Integration.hs
M cattrap.cabal

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

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