{-# 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 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, Font'(..),
                                                pattern2font, hbScale, CSSFont(..))
import           Graphics.Layout.Box as B (zeroBox, PaddedBox(..), Size(..))
import           Graphics.Layout (boxLayout, glyphsPerFont, LayoutItem(..), layoutGetChilds)
import           Graphics.Text.Font.Choose (nameParse)

import           FreeType.FontConfig (instantiatePattern, bmpAndMetricsForIndex,
                                      FTFC_Subpixel(..))
import           FreeType.Core.Base (ft_With_FreeType)
import           Typograffiti (makeDrawGlyphs, allocAtlas, AllocatedRendering(..),
                                TextTransform(..))
import           Linear.V4 (V4(..))
import           Linear.V2 (V2(..))
import           Data.Text.ParagraphLayout (Fragment(..))

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

import Data.Function (fix)
import Control.Monad (unless, forM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except (runExceptT)
import qualified Data.IntSet as IS
import qualified Data.Map.Strict as M

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

renderLayout drawText (LayoutSpan ((x, y), _) font self) = do
    drawText' <- drawText $ fragmentGlyphs self
    -- FIXME Allow CSS to set the colour.
    liftIO $ arDraw drawText' [TextTransformMultiply $ V4 0 0 0 1]
                    (V2 (fromEnum x) (fromEnum y))
renderLayout drawText node = layoutGetChilds node `forM` renderLayout drawText

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, scale'] <- 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 sysfont = (pattern2font (nameParse "serif") Style.temp { cssFontSize = (12,"pt") }
                   placeholderFont placeholderFont) { scale = read scale' }
    let inf = 1/0
    let infbox = zeroBox { B.min = Size inf inf, B.size = Size inf inf,
            B.max = Size inf inf }
    let layout0 = boxLayout infbox (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

    ft_With_FreeType $ \ft -> runExceptT $ do
        drawGlyphs <- makeDrawGlyphs
        atlases <- forM (M.toList $ glyphsPerFont layout0) $ \((pat, size), glyphs) -> do
            font <- liftIO $ instantiatePattern ft pat (-1, size)
            atlas <- allocAtlas (liftIO . bmpAndMetricsForIndex font SubpixelDefault)
                        (map toEnum $ IS.toList glyphs)
                        (realToFrac $ hbScale sysfont, realToFrac $ hbScale sysfont)
            return ((pat, size), atlas)
        let atlases' = M.fromList atlases

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

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

            let size = B.Size (fromIntegral dw) (fromIntegral dh)
            let outerbox = zeroBox { B.min = size, B.size = size, B.max = size }
            let layout = boxLayout outerbox (finalizeCSS' sysfont style) False

            renderLayout drawText layout

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