From 4969e25bcf3864e93844c1d6b7f4fa8ed77421bb Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Tue, 14 Mar 2023 12:20:02 +1300 Subject: [PATCH] Compute styletree. --- haphaestus.cabal | 7 ++- src/Main.hs | 120 ++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 125 insertions(+), 2 deletions(-) diff --git a/haphaestus.cabal b/haphaestus.cabal index 1df905a..5863962 100644 --- a/haphaestus.cabal +++ b/haphaestus.cabal @@ -20,6 +20,11 @@ executable haphaestus main-is: Main.hs -- other-modules: -- other-extensions: - build-depends: base >=4.12 && <4.13 + build-depends: base >=4.12 && <4.16, file-embed >= 0.0.9 && < 0.1, + hurl-xml >=0.2 && <1, network-uri, hurl, directory, + xml-conduit, containers, + stylist >= 2.5, stylist-traits, css-syntax, xml-conduit-stylist >=3, + text >= 2, bytestring, + cattrap >= 0.1 && <0.2 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs index 65ae4a0..89c8ee7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,122 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} module Main where +import qualified Data.ByteString.Lazy as B +import Data.Text (Text, unpack) +import qualified Data.Text as Txt +import qualified Data.Map as M +import System.Directory (getCurrentDirectory) +import qualified System.Directory as Dir +import Data.FileEmbed + +import Network.URI.Fetch.XML (fetchDocument, Page(..), loadVisited, applyCSScharset) +import Network.URI.Fetch (newSession, Session, fetchURL) +import Network.URI (URI(..), relativeTo, parseURIReference, nullURI) +import Network.URI.Charset (charsets) +import Text.XML (Document(..), Prologue(..), Element(..)) + +import qualified Data.CSS.Syntax.StyleSheet as CSS +import qualified Data.CSS.Style as Style +import Data.CSS.StyleTree +import qualified Data.CSS.Syntax.Tokens as CSSTok +import qualified Data.CSS.Preprocessor.Conditions as CSSCond +import Data.CSS.Preprocessor.Conditions (conditionalStyles) +import Data.CSS.Preprocessor.Assets +import qualified Data.CSS.Preprocessor.PsuedoClasses as CSSPseudo +import qualified Data.CSS.Preprocessor.Text as CSSTxt +import Stylist (cssPriorityAgent, cssPriorityUser, attrTest, elementPath) +import Stylist.Tree (treeFind) +import Data.HTML2CSS (el2stylist) + +import Data.Maybe (fromMaybe) +import System.Environment (getArgs) + +type Style = Style.VarParser (CSSTxt.TextStyle VizStyle) +data VizStyle = VizStyle +instance Style.PropertyParser VizStyle where + temp = VizStyle + inherit _ = VizStyle + longhand _ _ _ _ = Nothing + +inlinePseudos' :: Style.PropertyParser s => StyleTree [(Text, Style.VarParser s)] -> StyleTree s +inlinePseudos' (StyleTree self childs) = StyleTree { + style = fromMaybe Style.temp $ Style.innerParser <$> lookup "" self, + children = pseudo "before" ++ map inlinePseudos' childs ++ pseudo "after" + } where + pseudo n + | Just style <- Style.innerParser <$> lookup n self, + Just style' <- Style.longhand style style "::" [CSSTok.Ident n] = [StyleTree style' []] + | Just style <- Style.innerParser <$> lookup n self = [StyleTree style []] + | otherwise = [] + +loadUserStyles styles = do + dir <- Dir.getXdgDirectory Dir.XdgConfig "haphaestus" + 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 + + +retreiveStyles :: Session -> CSSCond.ConditionalStyles (Style) -> + IO (CSSCond.ConditionalStyles Style) +retreiveStyles manager authorStyle = do + let agentStyle = cssPriorityAgent authorStyle `CSS.parse` $(embedStringFile "useragent.css") + userStyle <- loadUserStyles agentStyle + CSSCond.loadImports loadURL lowerVars lowerToks userStyle [] + where + loadURL url = do + response <- fetchURL manager ["text/css"] url + let charsets' = map unpack charsets + return $ case response of + ("text/css", Left text) -> text + ("text/css", Right bytes) -> applyCSScharset charsets' $ B.toStrict bytes + (_, _) -> "" + +resolve' = CSSCond.resolve lowerVars lowerToks +lowerVars "speech" = CSSCond.B True +lowerVars "-rhapsode" = CSSCond.B True +lowerVars _ = CSSCond.B False +lowerToks _ = CSSCond.B False + main :: IO () -main = putStrLn "Hello, Haskell!" +main = do + sess <- newSession + cwd <- getCurrentDirectory + hist <- loadVisited "haphaestus" + let referer = 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 = hist, + initCSS = conditionalStyles, + appName = "haphaestus" + } + + [arg] <- getArgs + let uri = nullURI `fromMaybe` parseURIReference arg `relativeTo` pageURL referer + page <- fetchDocument sess referer uri + + let pseudofilter :: CSSPseudo.LowerPsuedoClasses (Style.QueryableStyleSheet Style) + pseudofilter = CSSPseudo.htmlPsuedoFilter Style.queryableStyleSheet + css <- retreiveStyles sess $ css page + let css' = CSSPseudo.inner $ resolve' pseudofilter css + let style = CSSTxt.resolve $ inlinePseudos' $ stylize css' $ el2stylist $ + documentRoot $ html page + + putStrLn "Hello, Haskell!" -- 2.30.2