{-# 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           Graphics.Layout.CSS (CSSBox(..), finalizeCSS')
import           Graphics.Layout.CSS.Internal (placeholderFont)
import           Graphics.Layout.Box (zeroBox, PaddedBox(..), Size(..))
import           Graphics.Layout (boxLayout)

import SDL hiding (rotate)
import Graphics.GL.Core32

import Data.Maybe (fromMaybe)
import System.Environment (getArgs)

type Style = Style.VarParser (CSSTxt.TextStyle (CSSBox 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 = 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

    let outerbox = zeroBox -- FIXME: Parameterize!
    let sysfont = placeholderFont -- FIXME: Parameterize!
    let layout = boxLayout zeroBox (finalizeCSS' sysfont style) False

    SDL.initializeAll
    let openGL = defaultOpenGL { glProfile = Core Debug 3 3 }
        wcfg = defaultWindow {
            windowInitialSize = V2 640 480,
            windowGraphicsContext = OpenGLContext openGL,
            windowResizable = True
          }
    w <- createWindow "Typograffiti" wcfg
    _ <- glCreateContext w

    fix $ \loop -> do
        events <- fmap eventPayload <$> pollEvents
        liftIO $ glClearColor 0 0 0 1
        liftIO $ glClear GL_COLOR_BUFFER_BIT

        sz@(V2 dw dh) <- liftIO $ glGetDrawableSize w
        liftIO $ glViewport 0 0 (fromIntegral dw) (fromIntegral dh)

        liftIO $ glSwapWindow w
        unless (QuitEvent `elem` events) loop
    return ()