{-# 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