{-# LANGUAGE CApiFFI, OverloadedStrings #-}
-- | A set of fonts to query, or resulting from a query.
module Graphics.Text.Font.Choose.FontSet(
        FontSet, validFontSet, fontSetList, fontSetMatch, fontSetSort, FontFaceParser(..), emptyParser
    ) 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.Text as Txt
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)

-- | holds a list of patterns; these are used to return the results of listing available fonts.
type FontSet = [Pattern]

-- | Can the FontSet be processed by FontConfig?
validFontSet :: FontSet -> Bool
validFontSet = all validPattern

-- | holds a list of patterns; these are used to return the results of listing available fonts.
-- If the fontset is invalid, 
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

-- | Finds the font in sets most closely matching pattern and returns the result
-- of `fontRenderPrepare` for that font and the provided pattern.
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

-- | Returns the list of fonts from sets sorted by closeness to pattern.
-- If True is passed, elements in the list which don't include Unicode coverage
-- not provided by earlier elements in the list are elided.
-- The union of Unicode coverage of all of the fonts is returned alongside the fontset.

-- Returns an empty CharSet & Nothing upon error, or invalid inputs.
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
------
-- | Variation of `withMessage` that's proving to be more concise.
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}

emptyParser :: a -> FontFaceParser a
emptyParser = FontFaceParser []

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 (Function "url":String link:RightParen:toks) =
    parseFontFaceSrc (Url link:toks) -- TODO: Why's this needed?

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 "weight" [(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 $ Txt.replace "/**/" "" $ 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 f) | f <- 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)