{-# LANGUAGE CApiFFI, OverloadedStrings #-}
module Graphics.Text.Font.Choose.FontSet(
        FontSet, validFontSet, fontSetList, fontSetMatch, fontSetSort, FontFaceParser(..)
    ) where

import Graphics.Text.Font.Choose.Pattern hiding (map)
import Graphics.Text.Font.Choose.Config
import Graphics.Text.Font.Choose.ObjectSet
import Graphics.Text.Font.Choose.CharSet as CS hiding (map)
import Graphics.Text.Font.Choose.Internal.FFI

import Foreign.C.String (CString)
import Foreign.Ptr (Ptr)
import Data.MessagePack (MessagePack)

import Stylist (StyleSheet(..))
import Stylist.Parse (parseProperties)
import Data.CSS.Syntax.Tokens (Token(..), serialize)
import Data.Text (Text, unpack)
import qualified Data.Map as M
import Data.List (intercalate)

import Graphics.Text.Font.Choose.Range (iRange)
import Graphics.Text.Font.Choose.Value (ToValue(..), Value)

type FontSet = [Pattern]

validFontSet :: FontSet -> Bool
validFontSet = all validPattern

fontSetList :: Config -> [FontSet] -> Pattern -> ObjectSet -> FontSet
fontSetList a b c d | all validFontSet b =
    fromMessage0 $ arg d $ arg c $ arg b $ withForeignPtr' fcFontSetList a
  | otherwise = []

foreign import capi "fontconfig-wrap.h" fcFontSetList ::
        Ptr Config' -> CString -> Int -> CString -> Int -> CString -> Int ->
        Ptr Int -> CString

fontSetMatch :: Config -> [FontSet] -> Pattern -> Maybe FontSet
fontSetMatch a b c | all validFontSet b && validPattern c =
        fromMessage $ arg c $ arg b $ withForeignPtr' fcFontSetMatch a
    | otherwise = Nothing

foreign import capi "fontconfig-wrap.h" fcFontSetMatch ::
        Ptr Config' -> CString -> Int -> CString -> Int -> Ptr Int -> CString

fontSetSort :: Config -> [FontSet] -> Pattern -> Bool -> (Maybe FontSet, CharSet')
fontSetSort a b c d | all validFontSet b && validPattern c =
        fromMessage0 $ flip withForeignPtr' a $ \a' ->
            arg b $ \b' x -> arg c $ \c' y -> fcFontSetSort a' b' x c' y d
    | otherwise = (Nothing, CharSet' CS.empty)

foreign import capi "fontconfig-wrap.h" fcFontSetSort ::
        Ptr Config' -> CString -> Int -> CString -> Int -> Bool -> Ptr Int -> CString

------
--- Utilities
------
arg :: MessagePack a => a -> (CString -> Int -> b) -> b
arg = flip withMessage

------
--- CSS Bindings
------

-- | `StyleSheet` wrapper to parse @font-face rules.
data FontFaceParser a = FontFaceParser { cssFonts :: FontSet, cssInner :: a}

parseFontFaceSrc :: [Token] -> [String]
parseFontFaceSrc (Function "local":Ident name:RightParen:Comma:rest) =
    ("local:" ++ unpack name):parseFontFaceSrc rest
parseFontFaceSrc (Function "local":String name:RightParen:Comma:rest) =
    ("local:" ++ unpack name):parseFontFaceSrc rest
parseFontFaceSrc (Function "local":Ident name:RightParen:[]) = ["local:" ++ unpack name]
parseFontFaceSrc (Function "local":String name:RightParen:[]) = ["local:" ++ unpack name]

parseFontFaceSrc (Url link:toks)
    | Comma:rest <- skipMeta toks = unpack link:parseFontFaceSrc rest
    | [] <- skipMeta toks = [unpack link]
    | otherwise = [""] -- Error indicator!
  where
    skipMeta (Function "format":Ident _:RightParen:rest) = skipMeta rest
    skipMeta (Function "format":String _:RightParen:rest) = skipMeta rest
    skipMeta (Function "tech":Ident _:RightParen:rest) = skipMeta rest
    skipMeta (Function "tech":String _:RightParen:rest) = skipMeta rest
    skipMeta toks' = toks'

parseFontFaceSrc _ = [""]

v :: ToValue x => x -> Value
v = toValue

properties2font :: [(Text, [Token])] -> Pattern
properties2font (("font-family", [String font]):props) =
    M.insert "family" [(Strong, v $ unpack font)] $ properties2font props
properties2font (("font-family", [Ident font]):props) =
    M.insert "family" [(Strong, v $ unpack font)] $ properties2font props

properties2font (("font-stretch", [tok]):props) | Just x <- parseFontStretch tok =
    M.insert "width" [(Strong, v x)] $ properties2font props
properties2font (("font-stretch", [start, end]):props)
    | Just x <- parseFontStretch start, Just y <- parseFontStretch end =
        M.insert "width" [(Strong, v $ iRange x y)] $ properties2font props

properties2font (("font-weight", [tok]):props) | Just x <- parseFontWeight tok =
    M.insert "width" [(Strong, v x)] $ properties2font props
properties2font (("font-weight", [start, end]):props)
    | Just x <- parseFontStretch start, Just y <- parseFontStretch end =
        M.insert "weight" [(Strong, v $ iRange x y)] $ properties2font props

properties2font (("font-feature-settings", toks):props)
    | (features, True, []) <- parseFontFeatures toks =
        M.insert "fontfeatures" [(Strong, v $ intercalate "," $ map fst features)] $
            properties2font props

properties2font (("font-variation-settings", toks):props)
    | (_, True, []) <- parseFontVars toks =
        M.insert "variable" [(Strong, v $ True)] $ properties2font props

properties2font (("unicode-range", toks):props)
    | Just chars <- parseCharSet $ unpack $ serialize toks =
        M.insert "charset" [(Strong, v $ CharSet' chars)] $ properties2font props

-- Ignoring metadata & trusting in FreeType's broad support for fonts.
properties2font (("src", toks):props)
    | fonts@(_:_) <- parseFontFaceSrc toks, "" `notElem` fonts =
        M.insert "web-src" [(Strong, v $ intercalate "\t" fonts)] $ properties2font props

properties2font (_:props) = properties2font props
properties2font [] = M.empty

instance StyleSheet a => StyleSheet (FontFaceParser a) where
    setPriorities prio (FontFaceParser x self) = FontFaceParser x $ setPriorities prio self
    addRule (FontFaceParser x self) rule = FontFaceParser x $ addRule self rule

    addAtRule (FontFaceParser fonts self) "font-face" toks =
        let ((props, _), toks') = parseProperties toks
        in (FontFaceParser (properties2font props:fonts) self, toks')
    addAtRule (FontFaceParser x self) key toks =
        let (a, b) = addAtRule self key toks in (FontFaceParser x a, b)