2 files changed, 125 insertions(+), 2 deletions(-)

M haphaestus.cabal
M src/Main.hs

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

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