{-# LANGUAGE OverloadedStrings, TemplateHaskell, FlexibleContexts #-}
module Main where

import           FreeType.FontConfig (instantiatePattern, bmpAndMetricsForIndex,
                                      FTFC_Subpixel(..))
import           FreeType.Core.Base (ft_With_FreeType, FT_Library)
import           Typograffiti (makeDrawGlyphs, allocAtlas, AllocatedRendering(..),
                                TextTransform(..), Atlas, TypograffitiError)
import SDL hiding (rotate)
import Graphics.GL.Core32

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except (runExceptT, MonadError, MonadIO)

import System.Environment (getArgs)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Text as Txt
import qualified Data.ByteString as BS
import System.Directory (getCurrentDirectory)
import qualified System.Directory as Dir

import Graphics.Layout.CSS (CSSBox(..), finalizeCSS')
import Graphics.Layout.CSS.Font (placeholderFont, pattern2font, hbUnit,
                                Font'(scale, pattern, fontSize),
                                CSSFont(cssFontSize))
import Graphics.Layout (LayoutItem(..), boxLayout,
                        glyphsPerFont, glyphs, fragmentFont,
                        layoutGetBox, layoutGetChilds, layoutGetInner)
import Graphics.Layout.Box (zeroBox)
import qualified Graphics.Layout.Box as B

import Network.URI.Fetch.XML (Page(..), fetchDocument, applyCSScharset)
import Network.URI.Fetch (newSession, fetchURL)
import Network.URI.Charset (charsets)
import Network.URI (URI(..), nullURI, parseURIReference)
import Data.FileEmbed (makeRelativeToProject, embedStringFile)
import Data.HTML2CSS (el2stylist)

import Text.XML as X (Document(..), Element(..), Node(..), Prologue(..))
import Stylist.Tree (StyleTree(..), preorder, treeMap)
import Stylist (PropertyParser(..), cssPriorityAgent, cssPriorityUser)
import qualified Data.CSS.Style as Style
import qualified Data.CSS.Syntax.StyleSheet as CSS
import qualified Data.CSS.Preprocessor.Text as CSSTxt
import Data.CSS.Preprocessor.Conditions as CSSCond
        (ConditionalStyles, conditionalStyles, loadImports, Datum(..), resolve)
import qualified Data.CSS.Preprocessor.PsuedoClasses as CSSPseudo

import Control.Concurrent.MVar (putMVar, newEmptyMVar, tryReadMVar)
import Control.Concurrent (forkIO)
import Control.DeepSeq (NFData(..), ($!!))

import SDL hiding (rotate)
import Foreign.C.Types (CInt)
import Data.Function (fix)
import Control.Monad (unless, forM)
import qualified Graphics.Text.Font.Choose as FC

import Data.CSS.Syntax.Tokens (Token(..))
import qualified Data.IntSet as IS
import Data.Text.Glyphize (GlyphInfo, GlyphPos)

type Style = Style.VarParser (CSSTxt.TextStyle (CSSBox VizStyle))
data VizStyle = VizStyle (V4 Float)
instance Eq VizStyle where
    VizStyle x == VizStyle y = case compare x y of
        EQ -> True
        _ -> False
instance Style.PropertyParser VizStyle where
    temp = VizStyle (V4 0 0 0 1)
    inherit = id
    longhand _ self "color" [Ident "black"] = Just $ VizStyle (V4 0 0 0 1)
    longhand _ self "color" [Ident "white"] = Just $ VizStyle (V4 1 1 1 1)
    longhand _ self "color" [Ident "red"]   = Just $ VizStyle (V4 1 0 0 1)
    longhand _ self "color" [Ident "green"] = Just $ VizStyle (V4 0 1 0 1)
    longhand _ self "color" [Ident "blue"]  = Just $ VizStyle (V4 0 0 1 1)
    longhand _ _ _ _ = Nothing

renderLayout :: (MonadError TypograffitiError m, MonadIO m) =>
        M.Map (FC.Pattern, Double) Atlas ->
        (Atlas -> [(GlyphInfo, GlyphPos)] ->
            m (AllocatedRendering [TextTransform])) ->
        LayoutItem Double Double ((Double, Double), VizStyle) ->
        m ()
renderLayout atlases drawText (LayoutSpan self)
        | Just atlas <- M.lookup (pattern font, fontSize font) atlases = do
    drawText' <- drawText atlas $ glyphs self
    liftIO $ arDraw drawText' [TextTransformMultiply color] $
        V2 (fromEnum x) (fromEnum y)
  where
    (font, _) = fragmentFont self
    ((x, y), VizStyle color) = layoutGetInner $ LayoutSpan self
renderLayout atlases drawText node = do
    layoutGetChilds node `forM` renderLayout atlases drawText
    return ()

initReferer :: IO (Page (CSSCond.ConditionalStyles (CSSBox VizStyle)))
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 = S.empty,
        initCSS = conditionalStyles,
        appName = "cattrap"
    }

stylize' style = preorder inner
  where
    inner parent _ el = Style.cascade style el [] $
            Style.inherit $ fromMaybe Style.temp parent

resolveCSS manager page = do
    let agentStyle = cssPriorityAgent (css page) `CSS.parse`
            $(makeRelativeToProject "useragent.css" >>= embedStringFile)
    userStyle <- loadUserStyles agentStyle
    CSSCond.loadImports loadURL lowerVars lowerToks userStyle []
  where
    loadURL url = do
        response <- fetchURL manager ["text/css"] url
        let charsets' = map Txt.unpack charsets
        return $ case response of
            ("text/css", Left text) -> text
            ("text/css", Right bytes) -> applyCSScharset charsets' $ BS.toStrict bytes
            (_, _) -> ""

loadUserStyles styles = do
    dir <- Dir.getXdgDirectory Dir.XdgConfig "rhapsode"
    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
-- FIXME: Support more media queries!
resolve' = CSSCond.resolve lowerVars lowerToks
lowerVars _ = CSSCond.B False
lowerToks _ = CSSCond.B False

main :: IO ()
main = do
    FC.init
    SDL.initializeAll

    let wcfg = defaultWindow {
            windowInitialSize = V2 1280 480,
            windowGraphicsContext = OpenGLContext defaultOpenGL {
                glProfile = Core Debug 3 3
            },
            -- Simplify moving layout/download out-of-thread
            windowResizable = False
          }
    w <- createWindow "Haphaestus" wcfg
    _ <- glCreateContext w

    args <- getArgs
    let url = case args of
            (url:_) -> url
            [] -> "https://haphaestus.org/"
    sess <- newSession
    ref <- initReferer
    xml <- fetchDocument sess ref $ fromMaybe nullURI $ parseURIReference url
    let pseudoFilter = CSSPseudo.htmlPsuedoFilter Style.queryableStyleSheet
    css' <- resolveCSS sess xml
    let css = CSSPseudo.inner $ resolve' pseudoFilter css'
    let styles = CSSTxt.resolve $ treeMap Style.innerParser $
            stylize' css $ el2stylist $ X.documentRoot $ html xml
    let layout = finalizeCSS' placeholderFont styles

    ft_With_FreeType $ \ft -> do
        V2 x y <- get $ windowSize w
        pages' <- forkCompute $ addAtlas ft $ boxLayout zeroBox {
                B.size = B.Size (fromIntegral x) (fromIntegral y)
              } layout True
        drawGlyphs' <- runExceptT makeDrawGlyphs
        let drawGlyphs = case drawGlyphs' of
                Left err -> error $ show err
                Right ret -> ret

        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)

            layout' <- tryReadMVar pages'
            res <- case layout' of
                Just (layout:_, atlases') -> runExceptT $
                    renderLayout atlases' drawGlyphs layout
                _ -> return $ Right ()
            case res of
                Left err -> print err
                Right () -> return ()

            liftIO $ glSwapWindow w
            unless (QuitEvent `elem` events) loop
    SDL.quit
    -- FC.fini -- FIXME: Need to free all Haskell data before freeing FontConfig's

c :: (Enum a, Enum b) => a -> b
c = toEnum . fromEnum

forkCompute dat = do
    ret <- liftIO $ newEmptyMVar
    liftIO $ forkIO (putMVar ret =<< dat)
    return ret

type Layouts = [LayoutItem Double Double ((Double, Double), VizStyle)]
addAtlas :: FT_Library -> Layouts -> IO (Layouts, M.Map (FC.Pattern, Double) Atlas)
addAtlas ft layout = do
    let sysfont = (pattern2font (FC.nameParse "serif") Style.temp { cssFontSize = (12,"pt") }
                   placeholderFont placeholderFont) { scale = 1 }

    let required = glyphsPerFont $ LayoutFlow ((0, 0), temp) zeroBox layout
    atlases <- forM (M.toList required) $ \(key@(pat, size), glyphs) -> do
        font <- instantiatePattern ft pat (-1, size)
        atlas <- runExceptT $ allocAtlas
                (liftIO . bmpAndMetricsForIndex font SubpixelDefault)
                (map toEnum $ IS.toList glyphs)
                (realToFrac $ hbUnit, realToFrac $ hbUnit)
        case atlas of
            Left err -> do
                print err
                return (key, Nothing)
            Right atlas' -> return (key, Just atlas')
    return (layout, M.fromList [(k, v) | (k, Just v) <- atlases])