{-# LANGUAGE DeriveGeneric, OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset,
    normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format,
    Pattern_, withPattern, thawPattern, thawPattern_, patternAsPointer,

    setValue, setValues, unset, getValues, getValues', getValue, getValue', getValue0,
    parseFontFamily, parseFontFeatures, parseFontVars, parseLength,
    parseFontStretch, parseFontWeight) where

import Prelude hiding (filter)
import Data.List (nub)

import Graphics.Text.Font.Choose.Value
import Graphics.Text.Font.Choose.ObjectSet (ObjectSet, ObjectSet_, withObjectSet)
import Data.Hashable (Hashable(..))
import GHC.Generics (Generic)
import Graphics.Text.Font.Choose.Result (throwFalse, throwNull, throwInt)

import Foreign.Ptr (Ptr)
import Foreign.Marshal.Alloc (alloca, allocaBytes, free)
import Foreign.Storable (Storable(..))
import Foreign.C.String (CString, withCString, peekCString)
import Debug.Trace (trace) -- For reporting internal errors!
import System.IO.Unsafe (unsafePerformIO)

import Control.Monad (forM, join)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Control.Exception (bracket)

-- Imported for CSS bindings
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.Text (unpack, Text)
import Stylist (PropertyParser(..))
import Data.Scientific (toRealFloat)
import Data.List (intercalate)

type Pattern = [(String, [(Binding, Value)])]
data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Show, Generic)

instance Hashable Binding where
    hash Strong = 0
    hash Weak = 1
    hash Same = 2

setValue :: ToValue x => String -> Binding -> x -> Pattern -> Pattern
setValue key b value pat = (key, [(b, toValue value)]):unset key pat
setValues :: ToValue x => String -> Binding -> [x] -> Pattern -> Pattern
setValues key b values pat = (key, [(b, toValue v) | v <- values]):unset key pat
getValues :: String -> Pattern -> [Value]
getValues key pat | Just ret <- lookup key pat = map snd ret
    | otherwise = []
getValues' key pat = mapMaybe fromValue $ getValues key pat
getValue :: String -> Pattern -> Value
getValue key pat | Just ((_, ret):_) <- lookup key pat = ret
    | otherwise = ValueVoid
getValue' :: ToValue x => String -> Pattern -> Maybe x
getValue' key pat = fromValue $ getValue key pat
getValue0 :: ToValue x => String -> Pattern -> x
getValue0 key pat = fromValue' $ getValue key pat

unset key mapping = [(key', val') | (key', val') <- mapping, key' /= key]

normalizePattern :: Pattern -> Pattern
normalizePattern pat =
    [(key, [val | (key', vals) <- pat, key' == key, val <- vals]) | key <- nub $ map fst pat]

equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool
equalSubset a b objs = unsafePerformIO $ withPattern a $ \a' -> withPattern b $ \b' ->
    withObjectSet objs $ fcPatternEqualSubset a' b'
foreign import ccall "FcPatternEqualSubset" fcPatternEqualSubset ::
    Pattern_ -> Pattern_ -> ObjectSet_ -> IO Bool

filter :: Pattern -> ObjectSet -> Pattern
filter pat objs =
    unsafePerformIO $ withPattern pat $ \pat' -> withObjectSet objs $ \objs' ->
        thawPattern_ $ fcPatternFilter pat' objs'
foreign import ccall "FcPatternFilter" fcPatternFilter ::
    Pattern_ -> ObjectSet_ -> IO Pattern_

defaultSubstitute :: Pattern -> Pattern
defaultSubstitute pat = unsafePerformIO $ withPattern pat $ \pat' -> do
    ret <- fcDefaultSubstitute pat'
    thawPattern pat'
foreign import ccall "FcDefaultSubstitute" fcDefaultSubstitute :: Pattern_ -> IO ()

-- Is this correct memory management?
nameParse :: String -> Pattern
nameParse name = unsafePerformIO $ withCString name $ \name' ->
    thawPattern_ $ fcNameParse name'
foreign import ccall "FcNameParse" fcNameParse :: CString -> IO Pattern_

nameUnparse :: Pattern -> String
nameUnparse pat = unsafePerformIO $ withPattern pat $ \pat' ->
    bracket (throwNull <$> fcNameUnparse pat') free peekCString
foreign import ccall "FcNameUnparse" fcNameUnparse :: Pattern_ -> IO CString

format :: Pattern -> String -> String
format pat fmt =
    unsafePerformIO $ withPattern pat $ \pat' -> withCString fmt $ \fmt' -> do
        bracket (throwNull <$> fcPatternFormat pat' fmt') free peekCString
foreign import ccall "FcPatternFormat" fcPatternFormat ::
    Pattern_ -> CString -> IO CString

------
--- Low-level
------

data Pattern'
type Pattern_ = Ptr Pattern'

withPattern :: Pattern -> (Pattern_ -> IO a) -> IO a
withPattern pat cb = withNewPattern $ \pat' -> do
    forM pat $ \(obj, vals) -> withCString obj $ \obj' -> do
        forM vals $ \(strength, val) -> throwFalse <$> withValue val
            (fcPatternAdd_ pat' obj' (strength == Strong) True)
    cb pat'
-- Does Haskell FFI support unboxed structs? Do I really need to write a C wrapper?
foreign import ccall "my_FcPatternAdd" fcPatternAdd_ ::
    Pattern_ -> CString -> Bool -> Bool -> Value_ -> IO Bool

patternAsPointer :: Pattern -> IO Pattern_
patternAsPointer = flip withPattern $ \ret -> do
    fcPatternReference ret
    return ret
foreign import ccall "FcPatternReference" fcPatternReference :: Pattern_ -> IO ()

data PatternIter'
type PatternIter_ = Ptr PatternIter'
foreign import ccall "size_PatternIter" patIter'Size :: Int
thawPattern :: Pattern_ -> IO Pattern
thawPattern pat' = allocaBytes patIter'Size $ \iter' -> do
    fcPatternIterStart pat' iter'
    ret <- go iter'
    return $ normalizePattern ret
  where
    go :: PatternIter_ -> IO Pattern
    go iter' = do
        ok <- fcPatternIterIsValid pat' iter'
        if ok then do
            x <- thawPattern' pat' iter'
            ok' <- fcPatternIterNext pat' iter'
            xs <- if ok' then go iter' else return []
            return (x : xs)
        else return []
foreign import ccall "FcPatternIterStart" fcPatternIterStart ::
    Pattern_ -> PatternIter_ -> IO ()
foreign import ccall "FcPatternIterIsValid" fcPatternIterIsValid ::
    Pattern_ -> PatternIter_ -> IO Bool
foreign import ccall "FcPatternIterNext" fcPatternIterNext ::
    Pattern_ -> PatternIter_ -> IO Bool

thawPattern' :: Pattern_ -> PatternIter_ -> IO (String, [(Binding, Value)])
thawPattern' pat' iter' = do
    obj <- peekCString =<< throwNull <$> fcPatternIterGetObject pat' iter'
    count <- fcPatternIterValueCount pat' iter'
    values <- forM [0..pred count] $ \i ->
        allocaBytes value'Size $ \val' -> alloca $ \binding' -> do
            res <- fcPatternIterGetValue pat' iter' i val' binding'
            throwInt res $ do
                binding <- peek binding'
                val' <- thawValue val'
                return $ case val' of
                    Just val | binding >= 0 && binding <= 2 -> Just (toEnum binding, val)
                    Just val -> Just (Same, val)
                    Nothing -> Nothing
    return (obj, catMaybes $ map join values)
foreign import ccall "FcPatternIterGetObject" fcPatternIterGetObject ::
    Pattern_ -> PatternIter_ -> IO CString
foreign import ccall "FcPatternIterValueCount" fcPatternIterValueCount ::
    Pattern_ -> PatternIter_ -> IO Int
foreign import ccall "FcPatternIterGetValue" fcPatternIterGetValue ::
    Pattern_ -> PatternIter_ -> Int -> Value_ -> Ptr Int -> IO Int

thawPattern_ cb = bracket (throwNull <$> cb) fcPatternDestroy thawPattern

withNewPattern cb = bracket (throwNull <$> fcPatternCreate) fcPatternDestroy cb
foreign import ccall "FcPatternCreate" fcPatternCreate :: IO Pattern_
foreign import ccall "FcPatternDestroy" fcPatternDestroy :: Pattern_ -> IO ()

------
--- Pattern
------

parseFontFamily :: [Token] -> ([String], Bool, [Token])
parseFontFamily (String font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail
    in (unpack font:fonts, b, tail')
parseFontFamily (Ident font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail
    in (unpack font:fonts, b, tail')
parseFontFamily (String font:tail) = ([unpack font], True, tail)
parseFontFamily (Ident font:tail) = ([unpack font], True, tail)
parseFontFamily toks = ([], False, toks) -- Invalid syntax!

parseFontFeatures :: [Token] -> ([(String, Int)], Bool, [Token])
parseFontFeatures (String feat:toks) | feature@(_:_:_:_:[]) <- unpack feat = case toks of
    Comma:tail -> let (feats, b, tail') = parseFontFeatures tail in ((feature, 1):feats, b, tail')
    Ident "on":Comma:tail -> let (f, b, t) = parseFontFeatures tail in ((feature, 1):f, b, t)
    Ident "on":tail -> ([(feature, 1)], True, tail)
    Ident "off":Comma:tail -> let (f, b, t) = parseFontFeatures tail in ((feature, 1):f, b, t)
    Ident "off":tail -> ([(feature, 1)], True, tail)
    Number _ (NVInteger x):Comma:tail ->
        let (feats, b, tail') = parseFontFeatures tail in ((feature, fromEnum x):feats, b, tail')
    Number _ (NVInteger x):tail -> ([(feature, fromEnum x)], True, tail)
parseFontFeatures toks = ([], False, toks)

parseFontVars :: [Token] -> ([(String, Double)], Bool, [Token])
parseFontVars (String var':Number _ x:Comma:tail) | var@(_:_:_:_:[]) <- unpack var' =
    let (vars, b, tail') = parseFontVars tail in ((var, nv2double x):vars, b, tail')
parseFontVars (String var':Number _ x:tail) | var@(_:_:_:_:[]) <- unpack var' =
    ([(var, nv2double x)], True, tail)
parseFontVars toks = ([], False, toks)

parseLength :: Double -> NumericValue -> Text -> Double
parseLength super length unit = convert (nv2double length) unit
  where
    convert = c
    c x "pt" = x -- Unit FontConfig expects!
    c x "pc" = x/6 `c` "in"
    c x "in" = x/72 `c` "pt"
    c x "Q" = x/40 `c` "cm"
    c x "mm" = x/10 `c` "cm"
    c x "cm" = x/2.54 `c` "in"
    c x "px" = x/96 `c` "in" -- Conversion factor during early days of CSS, got entrenched.
    c x "em" = x * super
    c x "%" = x/100 `c` "em"
    c _ _ = 0/0 -- NaN

parseFontStretch :: Token -> Maybe Int -- Result in percentages
parseFontStretch (Percentage _ x) = Just $ fromEnum $ nv2double x
parseFontStretch (Ident "ultra-condensed") = Just 50
parseFontStretch (Ident "extra-condensed") = Just 63 -- 62.5%, but round towards 100%
parseFontStretch (Ident "condensed") = Just 75
parseFontStretch (Ident "semi-condensed") = Just 88 -- 87.5% actually...
parseFontStretch (Ident "normal") = Just 100
parseFontStretch (Ident "initial") = Just 100
parseFontStretch (Ident "semi-expanded") = Just 112 -- 112.5% actually...
parseFontStretch (Ident "expanded") = Just 125
parseFontStretch (Ident "extra-expanded") = Just 150
parseFontStretch (Ident "ultra-expanded") = Just 200
parseFontStretch _ = Nothing

-- Conversion between CSS scale & FontConfig scale is non-trivial, use lookuptable.
parseFontWeight :: Token -> Maybe Int
parseFontWeight (Ident k) | k `elem` ["initial", "normal"] = Just 80
parseFontWeight (Ident "bold") = Just 200
parseFontWeight (Number _ (NVInteger 100)) = Just 0
parseFontWeight (Number _ (NVInteger 200)) = Just 40
parseFontWeight (Number _ (NVInteger 300)) = Just 50
parseFontWeight (Number _ (NVInteger 400)) = Just 80
parseFontWeight (Number _ (NVInteger 500)) = Just 100
parseFontWeight (Number _ (NVInteger 600)) = Just 180
parseFontWeight (Number _ (NVInteger 700)) = Just 200
parseFontWeight (Number _ (NVInteger 800)) = Just 205
parseFontWeight (Number _ (NVInteger 900)) = Just 210
parseFontWeight (Number _ (NVInteger 950)) = Just 215
parseFontWeight (Number _ (NVInteger x))
    | x > 920 = parseFontWeight $ Number "" $ NVInteger 950
    | otherwise = parseFontWeight $ Number "" $ NVInteger $ (x `div` 100) * 100
parseFontWeight _ = Nothing

nv2double (NVInteger x) = fromInteger x
nv2double (NVNumber x) = toRealFloat x

sets a b c d = Just $ setValues a b c d
set a b c d = Just $ setValue a b c d
seti a b c d = Just $ setValue a b (c :: Int) d
unset' a b = Just $ unset a b

getSize pat | ValueDouble x <- getValue "size" pat = x
    | otherwise = 10

instance PropertyParser Pattern where
    temp = []

    longhand _ self "font-family" toks
        | (fonts, True, []) <- parseFontFamily toks = sets "family" Strong fonts self

    -- font-size: initial should be configurable!
    longhand super self "font-size" [Dimension _ x unit]
        | let y = parseLength (getSize super) x unit, not $ isNaN y =
            set "size" Strong y self
    longhand super self "font-size" [Percentage x y] =
        longhand super self "font-size" [Dimension x y "%"]

    longhand _ self "font-style" [Ident "initial"] = seti "slant" Strong 0 self
    longhand _ self "font-style" [Ident "normal"] = seti "slant" Strong 0 self
    longhand _ self "font-style" [Ident "italic"] = seti "slant" Strong 100 self
    longhand _ self "font-style" [Ident "oblique"] = seti "slant" Strong 110 self

    -- Conversion between CSS scale & FontConfig scale is non-trivial, use lookuptable.
    longhand _ self "font-weight" [tok]
        | Just x <- parseFontWeight tok = seti "weight" Strong x self
    longhand super self "font-weight" [Number _ (NVInteger x)]
        | x > 920 = longhand super self "font-weight" [Number "" $ NVInteger 950]
        | otherwise = longhand super self "font-weight" [Number "" $ NVInteger $ (x `div` 100) * 100]
    longhand _ self "font-weight" [Ident "lighter"]
        | ValueInt x <- getValue "weight" self, x > 200 = seti "weight" Strong 200 self
        -- minus 100 adhears to the CSS standard awefully well in this new scale.
        | ValueInt x <- getValue "weight" self = seti "weight" Strong (max (x - 100) 0) self
        | otherwise = seti "weight" Strong 0 self
    longhand _ self "font-weight" [Ident "bolder"]
        | ValueInt x <- getValue "weight" self, x <= 65 = seti "weight" Strong 80 self
        | ValueInt x <- getValue "weight" self, x <= 150 = seti "weight" Strong 200 self
        | ValueInt x <- getValue "weight" self, x < 210 = seti "weight" Strong 210 self
        | ValueInt _ <- getValue "weight" self = Just self -- As bold as it goes...
        | otherwise = seti "weight" Strong 200 self

    longhand _ self "font-feature-settings" [Ident k]
        | k `elem` ["initial", "normal"] = unset' "fontfeatures" self
    longhand _ self "font-feature-settings" toks
        | (features, True, []) <- parseFontFeatures toks =
            set "fontfeatures" Strong (intercalate "," $ map fst features) self

    longhand _ self "font-variation-settings" [Ident k]
        | k `elem` ["initial", "normal"] = unset' "variable" self
    longhand _ self "font-variation-settings" toks
        | (_, True, []) <- parseFontVars toks = set "variable" Strong True self

    longhand _ s "font-stretch" [tok]
        | Just x <- parseFontStretch tok = seti "width" Strong x s

    longhand _ _ _ _ = Nothing