{-# LANGUAGE OverloadedStrings #-}
module Graphics.Text.Font.Choose.FontSet where

import Graphics.Text.Font.Choose.Pattern
import Graphics.Text.Font.Choose.Result (throwFalse, throwNull)

import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (pokeElemOff, sizeOf)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Marshal.Array (peekArray, allocaArray)
import Control.Monad (forM)
import Control.Exception (bracket)
import System.IO.Unsafe (unsafeInterleaveIO)

-- For CSS bindings
import Stylist.Parse (StyleSheet(..), parseProperties)
import Data.CSS.Syntax.Tokens (Token(..), serialize)
import Data.Text (unpack, Text)
import Graphics.Text.Font.Choose.Range (iRange)
import Graphics.Text.Font.Choose.CharSet (parseCharSet)
import Data.List (intercalate)

-- | An `FontSet` contains a list of `Pattern`s.
-- Internally fontconfig uses this data structure to hold sets of fonts.
-- Externally, fontconfig returns the results of listing fonts in this format.
type FontSet = [Pattern]

------
--- Low-level
------
data FontSet'
type FontSet_ = Ptr FontSet'

withNewFontSet :: (FontSet_ -> IO a) -> IO a
withNewFontSet = bracket fcFontSetCreate fcFontSetDestroy
foreign import ccall "FcFontSetCreate" fcFontSetCreate :: IO FontSet_
foreign import ccall "FcFontSetDestroy" fcFontSetDestroy :: FontSet_ -> IO ()

withFontSet :: FontSet -> (FontSet_ -> IO a) -> IO a
withFontSet fonts cb = withNewFontSet $ \fonts' -> do
    forM fonts $ \font -> do
        font' <- patternAsPointer font
        throwFalse <$> fcFontSetAdd fonts' font'
    cb fonts'
foreign import ccall "FcFontSetAdd" fcFontSetAdd :: FontSet_ -> Pattern_ -> IO Bool

withFontSets :: [FontSet] -> (Ptr FontSet_ -> Int -> IO a) -> IO a
withFontSets fontss cb = let n = length fontss in
    allocaArray n $ \fontss' ->
        withFontSets' fontss 0 fontss' $ cb fontss' n
withFontSets' :: [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a
withFontSets' [] _ _ cb = cb
withFontSets' (fonts:fontss) i fontss' cb = withFontSet fonts $ \fonts' -> do
    pokeElemOff fontss' i fonts'
    withFontSets' fontss (succ i) fontss' cb

thawFontSet :: FontSet_ -> IO FontSet
thawFontSet fonts' = do
    n <- get_fontSet_nfont fonts'
    if n == 0 then return []
    else
        forM [0..pred n] (\i -> thawPattern' =<< get_fontSet_font fonts' i)
  where
    thawPattern' pat = do
        fcPatternReference pat
        unsafeInterleaveIO $ thawPattern pat
foreign import ccall "get_fontSet_nfont" get_fontSet_nfont :: FontSet_ -> IO Int
foreign import ccall "get_fontSet_font" get_fontSet_font :: FontSet_ -> Int -> IO Pattern_

thawFontSet_ :: IO FontSet_ -> IO FontSet
thawFontSet_ cb = bracket (throwNull <$> cb) fcFontSetDestroy thawFontSet

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

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

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 _ = [""]

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

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

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

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

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

properties2font (("unicode-range", toks):props)
    | Just chars <- parseCharSet $ unpack $ serialize toks =
        setValue "charset" Strong chars $ properties2font props

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

properties2font (_:props) = properties2font props
properties2font [] = []

instance StyleSheet a => StyleSheet (FontFaceParser a) where
    setPriorities v (FontFaceParser x self) = FontFaceParser x $ setPriorities v 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)