{-# LANGUAGE OverloadedStrings #-}
module Graphics.Layout.CSS.Font(Font'(..), placeholderFont, hbScale, hbUnit,
        pattern2hbfont, pattern2font, CSSFont(..), variations') where

import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..), serialize)
import Stylist (PropertyParser(..))
import qualified Data.Text as Txt
import Data.Maybe (fromMaybe)

import Graphics.Layout.Box
import Graphics.Layout.CSS.Length

import Data.Text.Glyphize as HB
import Graphics.Text.Font.Choose (Pattern(..), Value(..), normalizePattern,
                                  getValue', getValue0, setValue, Binding(..),
                                  configSubstitute', defaultSubstitute,
                                  fontSort', MatchKind(..), fontRenderPrepare')
import qualified Data.ByteString as B
import System.IO.Unsafe (unsafePerformIO)

placeholderFont = Font' undefined [] (const 0) (const 0) 0 0 0 0  0 0 0 0  1
hbScale :: Font' -> Double
hbScale f = fontSize f*hbUnit
hbUnit = 64 :: Double

pattern2hbfont :: Pattern -> Int -> [Variation] -> Font
pattern2hbfont pat scale variations = createFontWithOptions options face
  where
    bytes = unsafePerformIO $ B.readFile $ getValue0 "file" pat
    face = createFace bytes $ toEnum $ fromMaybe 0 $ getValue' "index" pat
    options = foldl value2opt defaultFontOptions { optionScale = Just (scale, scale) } $
                normalizePattern pat

    value2opt opts ("slant", (_, ValueInt x):_) = opts {
        optionSynthSlant = Just $ realToFrac x
      }
    value2opt opts ("fontvariations", _:_) = opts {optionVariations = variations}
    value2opt opts _ = opts

pattern2font :: Pattern -> CSSFont -> Font' -> Font' -> Font'
pattern2font pat styles@CSSFont { cssFontSize = (x,"initial") } parent root =
    pattern2font pat styles { cssFontSize = (x*fontSize root," ") } parent root
pattern2font pat styles parent root = Font' {
        hbFont = font',
        pattern = font,
        fontHeight = height' . fontGlyphExtents font' . fontGlyph',
        fontAdvance = fromIntegral . fontGlyphHAdvance font' . fontGlyph',
        fontSize = fontSize',
        rootEm = fontSize root,
        lineheight = lineheight',
        rlh = lineheight root,

        vh = vh root,
        vw = vw root,
        vmax = vmax root,
        vmin = vmin root,
        scale = scale root
    } where
        height' (Just x) = fromIntegral $ HB.height x
        height' Nothing = fontSize'
        lineheight' | snd (cssLineheight styles) == "normal",
            Just extents <- fontHExtents font' = (fromIntegral $ lineGap extents)/scale'
            | otherwise = lowerLength' (cssLineheight styles) parent
        fontSize' = lowerLength' (cssFontSize styles) parent
        lowerLength' a = lowerLength (fontSize parent) . finalizeLength a
        fontGlyph' ch = fromMaybe 0 $ fontGlyph font' ch Nothing
        q | Nothing <- lookup "family" pat, Just val <- lookup "family" $ pattern root =
                ("family", val):setValue "size" Weak (px2pt root fontSize') pat
            | otherwise = setValue "size" Weak (px2pt root fontSize') pat
        font = case fontSort' (defaultSubstitute $ configSubstitute' q MatchPattern) False of
            Just (font:_, _) -> fontRenderPrepare' q font
            _ -> error "TODO: Set fallback font!"
        font' = pattern2hbfont font (round scale') $ variations' fontSize' styles
        scale' = fontSize'*hbUnit

data CSSFont = CSSFont {
    cssFontSize :: Unitted,
    cssLineheight :: Unitted,
    variations :: [Variation],
    weightVariation :: Variation,
    widthVariation :: Variation,
    slantVariation :: Variation,
    opticalSize :: Bool
}
variations' :: Double -> CSSFont -> [Variation]
variations' fontsize self =
    (if opticalSize self then (Variation opsz (realToFrac fontsize):) else id)
    (slantVariation self:widthVariation self:weightVariation self:variations self)

fracDefault :: CSSFont -> Double -> Maybe CSSFont
fracDefault self frac = Just self {
    cssFontSize = (frac,"initial")
}
instance PropertyParser CSSFont where
    temp = CSSFont {
        cssFontSize = (12,"pt"),
        cssLineheight = (1,""),
        variations = [],
        weightVariation = Variation wght 400,
        widthVariation = Variation wdth 100,
        slantVariation = Variation ital 0,
        opticalSize = True
    }
    inherit parent = parent

    longhand _ self "font-size" [Ident "xx-small"] = fracDefault self $ 3/5
    longhand _ self "font-size" [Ident "x-small"] = fracDefault self $ 3/4
    longhand _ self "font-size" [Ident "small"] = fracDefault self $ 8/9
    longhand _ self "font-size" [Ident "medium"] = fracDefault self 1
    longhand _ self "font-size" [Ident "initial"] = fracDefault self 1
    longhand _ self "font-size" [Ident "large"] = fracDefault self $ 6/5
    longhand _ self "font-size" [Ident "x-large"] = fracDefault self $ 3/2
    longhand _ self "font-size" [Ident "xx-large"] = fracDefault self 2
    longhand _ self "font-size" [Ident "xxx-large"] = fracDefault self 3
    longhand parent self "font-size" [Ident "larger"] =
        Just self { cssFontSize = (x*1.2,unit) }
      where (x,unit) = cssFontSize parent
    longhand parent self "font-size" [Ident "smaller"] =
        Just self { cssFontSize = (x/1.2,unit) }
      where (x, unit) = cssFontSize parent
    longhand _ self "font-size" toks
        | Just x <- parseLength toks = Just self { cssFontSize = x }

    longhand _ self "line-height" [Ident "normal"] = Just self { cssLineheight = (0,"normal") }
    longhand _ self "line-height" [Number _ x] = Just self { cssLineheight = (n2f x,"em") }
    longhand _ self "line-height" toks
        | Just x <- parseLength toks = Just self { cssLineheight = x }

    longhand _ self "font-variation-settings" [Ident "normal"] = Just self { variations = [] }
    longhand _ self "font-variation-settings" [Ident "initial"] = Just self {variations = []}
    longhand _ self "font-variation-settings" toks
        | Just x <- parseVariations toks = Just self { variations = x }

    longhand _ self "font-weight" [Ident "normal"] =
        Just self { weightVariation = Variation wght 400 }
    longhand _ self "font-weight" [Ident "initial"] =
        Just self { weightVariation = Variation wght 400 }
    longhand _ self "font-weight" [Ident "bold"] =
        Just self { weightVariation = Variation wght 700 }
    longhand _ self "font-weight" [Number _ (NVInteger x)] | x >= 100 && x < 1000 =
        Just self { weightVariation = Variation wght $ fromIntegral x }
    longhand parent self "font-weight" [Ident "bolder"]
        | varValue (weightVariation parent) < 400 =
            Just self { weightVariation = Variation wght 400 }
        | varValue (weightVariation parent) < 600 =
            Just self { weightVariation = Variation wght 700 }
        | otherwise = Just self { weightVariation = Variation wght 900 }
    longhand parent self "font-weight" [Ident "lighter"]
        | varValue (weightVariation parent) < 600 =
            Just self { weightVariation = Variation wght 100 }
        | varValue (weightVariation parent) < 800 =
            Just self { weightVariation = Variation wght 400 }
        | otherwise = Just self { weightVariation = Variation wght 700 }

    longhand _ self "font-stretch" [Ident "ultra-condensed"] =
        Just self { widthVariation = Variation wdth 50 }
    longhand _ self "font-stretch" [Ident "extra-condensed"] =
        Just self { widthVariation = Variation wdth 62.5 }
    longhand _ self "font-stretch" [Ident "condensed"] =
        Just self { widthVariation = Variation wdth 75 }
    longhand _ self "font-stretch" [Ident "semi-condensed"] =
        Just self { widthVariation = Variation wdth 87.5 }
    longhand _ self "font-stretch" [Ident k] | k `elem` ["initial", "normal"] =
        Just self { widthVariation = Variation wdth 100 }
    longhand _ self "font-stretch" [Ident "semi-expanded"] =
        Just self { widthVariation = Variation wdth 112.5 }
    longhand _ self "font-stretch" [Ident "expanded"] =
        Just self { widthVariation = Variation wdth 125 }
    longhand _ self "font-stretch" [Ident "extra-expanded"] =
        Just self { widthVariation = Variation wdth 150 }
    longhand _ self "font-stretch" [Ident "ultra-expanded"] =
        Just self { widthVariation = Variation wdth 200 }
    longhand _ self "font-stretch" [Percentage _ x] =
        Just self { widthVariation = Variation wdth $ n2f x }

    longhand _ self "font-style" [Ident "oblique", Dimension _ x "deg"] =
        Just self { slantVariation = Variation slnt $ n2f x }
    longhand _ self "font-style" [Ident "oblique", Dimension _ x "grad"] =
        Just self { slantVariation = Variation slnt (n2f x/400*360) }
    longhand _ self "font-style" [Ident "oblique", Dimension _ x "rad"] =
        Just self { slantVariation = Variation slnt (n2f x*180/pi) }
    longhand _ self "font-style" [Ident "oblique", Dimension _ x "turn"] =
        Just self { slantVariation = Variation slnt (n2f x*360) }
    longhand _ self "font-style" [Ident "italic"] =
        Just self { slantVariation = Variation ital 1 }
    longhand _ self "font-style" [Ident "normal"] =
        Just self { slantVariation = Variation ital 0 }
    longhand _ self "font-style" [Ident "initial"] =
        Just self { slantVariation = Variation ital 0 }

    longhand _ s "font-optical-sizing" [Ident "auto"] = Just s {opticalSize = True}
    longhand _ s "font-optical-sizing" [Ident "initial"] = Just s {opticalSize = True}
    longhand _ s "font-optical-sizing" [Ident "none"] = Just s {opticalSize = False}

    longhand _ _ _ _ = Nothing

parseVariations (x@(String _):y@(Number _ _):Comma:toks)
    | Just var <- parseVariation $ Txt.unpack $ serialize [x, y],
        Just vars <- parseVariations toks = Just $ var:vars
parseVariations toks@[String _, Number _ _]
    | Just var <- parseVariation $ Txt.unpack $ serialize toks = Just [var]
parseVariations _ = Nothing

wght = tag_from_string "wght"
wdth = tag_from_string "wdth"
slnt = tag_from_string "slnt"
ital = tag_from_string "ital"
opsz = tag_from_string "opsz"