{-# LANGUAGE OverloadedStrings #-}
module Graphics.Layout.CSS.Internal where

import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..), serialize)
import Stylist (PropertyParser(..))
import qualified Data.Text as Txt
import Data.Scientific (toRealFloat)
import Debug.Trace (trace) -- For warnings.
import Data.Maybe (fromMaybe)

import Graphics.Layout.Box

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)

type Unitted = (Double, Txt.Text)
auto :: Unitted
auto = (0,"auto")

parseLength :: [Token] -> Maybe Unitted
parseLength [Percentage _ x] = Just (n2f x,"%")
parseLength [Dimension _ x unit]
    | n2f x == 0 && unit == "" = Just (0,"px")
    | unit `elem` units = Just (n2f x,unit)
parseLength [Ident "auto"] = Just (0,"auto")
parseLength [Ident "initial"] = Just (0,"auto")
parseLength _ = Nothing
parseLength' [Ident "min-content"] = Just (0,"min-content")
parseLength' [Ident "max-content"] = Just (0,"max-content")
parseLength' toks = parseLength toks

units = Txt.words "cap ch em ex ic lh rem rlh vh vw vmax vmin px cm mm Q in pc pt %"

n2f (NVInteger x) = realToFrac x
n2f (NVNumber x) = toRealFloat x

finalizeLength :: Unitted -> Font' -> Length
finalizeLength (x,"cap") f = Pixels $ x*fontHeight f 'A'
finalizeLength (x,"ch") f = Pixels $ x*fontAdvance f '0'
finalizeLength (x,"em") f = Pixels $ x*fontSize f
finalizeLength (x,"") f = Pixels $ x*fontSize f -- For line-height.
finalizeLength (x,"ex") f = Pixels $ x*fontHeight f 'x'
finalizeLength (x,"ic") f = Pixels $ x*fontHeight f '水' -- CJK water ideograph
finalizeLength (x,"lh") f = Pixels $ x*lineheight f
finalizeLength (x,"rem") f = Pixels $ x*rootEm f
finalizeLength (x,"rlh") f = Pixels $ x*rlh f
finalizeLength (x,"vh") f = Pixels $ x*vh f
finalizeLength (x,"vw") f = Pixels $ x*vw f
finalizeLength (x,"vmax") f = Percent $ x*vmax f
finalizeLength (x,"vmin") f = Percent $ x*vmin f
finalizeLength (x,"px") f = Pixels $ x*scale f
finalizeLength (x,"cm") f = Pixels $ x*scale f*96/2.54
finalizeLength (x,"in") f = Pixels $ x*96*scale f
finalizeLength (x,"mm") f | Pixels x' <- finalizeLength (x,"cm") f = Pixels $ x'/10
finalizeLength (x,"Q") f | Pixels x' <- finalizeLength (x,"cm") f = Pixels $ x'/40
finalizeLength (x,"pc") f | Pixels x' <- finalizeLength (x,"in") f = Pixels $ x'/6
finalizeLength (x,"pt") f | Pixels x' <- finalizeLength (x,"in") f = Pixels $ x'/72
finalizeLength (x,"%") _ = Percent $ x/100
finalizeLength (_,"auto") _ = Auto
finalizeLength (_,"min-content") _ = Min
finalizeLength (_,"max-content") _ = Preferred
finalizeLength (x, " ") _ = Pixels x -- Internal constant value...
finalizeLength (_,unit) _ = trace ("Invalid unit " ++ Txt.unpack unit) $ Pixels 0
px2pt f x = x / scale f / 96 * 72

data Font' = Font' {
    hbFont :: Font,
    pattern :: Pattern,
    fontHeight :: Char -> Double,
    fontAdvance :: Char -> Double,
    fontSize :: Double,
    rootEm :: Double,
    lineheight :: Double,
    rlh :: Double,
    vh :: Double,
    vw :: Double,
    vmax :: Double,
    vmin :: Double,
    scale :: Double
}
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"