{-# LANGUAGE DeriveGeneric, CApiFFI #-}
{-# LANGUAGE OverloadedStrings #-}
module Graphics.Text.Font.Choose.Pattern(Pattern, Pattern'(..), module M, Binding(..),
        setValue, setValues, getValue, getValues, equalSubset, defaultSubstitute,
        nameParse, nameUnparse, nameFormat, validPattern, validPattern',
        -- For Graphics.Text.Font.Choose.FontSet
        parseFontStretch, parseFontWeight, parseFontFeatures, parseFontVars) where

import Data.Map as M
import Data.MessagePack (MessagePack(..), Object(..))
import Test.QuickCheck (Arbitrary(..), elements)
import Data.Hashable (Hashable(..))
import GHC.Generics (Generic)

import Foreign.C.String (CString)
import Foreign.Ptr (Ptr)
import Control.Exception (throw)
import Graphics.Text.Font.Choose.Internal.FFI (withMessage, fromMessage0, withCString', peekCString')

import Graphics.Text.Font.Choose.Value
import Graphics.Text.Font.Choose.ObjectSet
import Graphics.Text.Font.Choose.Result
import Graphics.Text.Font.Choose.Weight

import Stylist (PropertyParser(..))
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.Text (Text, unpack)
import qualified Data.Text as Txt
import Data.Scientific (toRealFloat)
import Data.List (intercalate)
import Data.Maybe as Mb (listToMaybe, fromMaybe, mapMaybe)
import Data.Char (isAscii)
import Prelude as L

type Pattern = M.Map Text [(Binding, Value)]
data Pattern' = Pattern' { unPattern :: Pattern } deriving (Eq, Read, Show, Generic)
data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Read, Show, Generic)

instance Hashable Binding where
    hash = fromEnum
instance MessagePack Binding where
    fromObject (ObjectBool True) = Just Strong
    fromObject (ObjectBool False) = Just Weak
    fromObject ObjectNil = Just Same
    fromObject _ = Nothing
    toObject Strong = ObjectBool True
    toObject Weak = ObjectBool False
    toObject Same = ObjectNil

instance Hashable Pattern' where hash = hash . unPattern
instance MessagePack Pattern' where
    fromObject = fmap Pattern' . fromObject
    toObject = toObject . unPattern

instance Arbitrary Pattern' where
    -- FIXME: Stop enforcing singletons, without incurring too many invalid patterns!
    arbitrary = Pattern' <$> M.mapKeys normKey <$> M.map (:[]) <$> arbitrary
        where
            normKey = Txt.pack . L.filter (/= '\0') . L.map toAscii . L.take 17
            toAscii :: Char -> Char
            toAscii ch = toEnum $ fromEnum ch `mod` 128
instance Arbitrary Binding where
    arbitrary = elements [Strong, Weak] -- Same doesn't roundtrip!

validPattern :: Pattern -> Bool
validPattern self = not (M.null self) &&
        all (validValue . snd) (concat $ M.elems self) &&
        all (not . L.null) (M.elems self) &&
        all (not . Txt.null) (M.keys self) &&
        all ((/= Same) . fst) (concat $ M.elems self) &&
        all (not . Txt.elem '\0') (M.keys self) &&
        all (Txt.all isAscii) (M.keys self) &&
        all (\k -> Txt.length k < 18) (M.keys self)
validPattern' :: Pattern' -> Bool
validPattern' = validPattern . unPattern

setValue :: ToValue v => Text -> Binding -> v -> Pattern -> Pattern
setValue key strength v self = setValues key strength [v] self
setValues :: ToValue v => Text -> Binding -> [v] -> Pattern -> Pattern
setValues key strength vs self = M.insert key [(strength, toValue v) | v <- vs] self

getValue :: ToValue v => Text -> Pattern -> Maybe v
getValue key self = fromValue . snd =<< listToMaybe =<< M.lookup key self
getValues :: ToValue v => Text -> Pattern -> [v]
getValues key self = Mb.mapMaybe (fromValue . snd) $ fromMaybe [] $ M.lookup key self

equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool
equalSubset a b os | validPattern a && validPattern b =
    case withMessage fcPatternEqualSubset [toObject a, toObject b, toObject os] of
        0 -> False
        1 -> True
        _ -> throw ErrOOM
  | otherwise = False

foreign import capi "fontconfig-wrap.h" fcPatternEqualSubset :: CString -> Int -> Int

defaultSubstitute :: Pattern -> Pattern
defaultSubstitute a | validPattern a = fromMessage0 $ withMessage fcDefaultSubstitute a
    | otherwise = a

foreign import capi "fontconfig-wrap.h" fcDefaultSubstitute :: CString -> Int -> Ptr Int -> CString

nameParse :: String -> Pattern
nameParse = fromMessage0 . withCString' fcNameParse

foreign import capi "fontconfig-wrap.h" fcNameParse :: CString -> Ptr Int -> CString

nameUnparse :: Pattern -> String
nameUnparse a | validPattern a = peekCString' $ withMessage fcNameUnparse a
    | otherwise = ""

foreign import capi "fontconfig-wrap.h" fcNameUnparse :: CString -> Int -> CString

nameFormat :: Pattern -> String -> String
nameFormat a b
    | validPattern a = peekCString' $ flip withCString' b $ withMessage fcNameFormat a
    | otherwise = ""

foreign import capi "fontconfig-wrap.h" fcNameFormat :: CString -> Int -> CString -> CString

------
--- CSS
------

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

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

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

parseLength :: Double -> NumericValue -> Text -> Double
parseLength super len unit = convert (nv2double len) 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 x)) = Just $ weightFromOpenType $ fromEnum x
parseFontWeight _ = Nothing

nv2double :: NumericValue -> Double
nv2double (NVInteger x) = fromInteger x
nv2double (NVNumber x) = toRealFloat x

sets :: ToValue v => Text -> Binding -> [v] -> Pattern -> Maybe Pattern
sets a b c d = Just $ setValues a b c d
set :: ToValue v => Text -> Binding -> v -> Pattern -> Maybe Pattern
set a b c d = Just $ setValue a b c d
seti :: Text -> Binding -> Int -> Pattern -> Maybe Pattern
seti a b c d = Just $ setValue a b (c :: Int) d
unset' :: Text -> Pattern -> Maybe Pattern
unset' a b = Just $ M.delete a b

getSize :: Pattern -> Double
getSize pat | Just [(_, ValueDouble x)] <- M.lookup "size" pat = x
    | otherwise = 10

instance PropertyParser Pattern' where
    temp = Pattern' M.empty

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

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

    longhand _ (Pattern' self) "font-style" [Ident "initial"] = Pattern' <$> seti "slant" Strong 0 self
    longhand _ (Pattern' self) "font-style" [Ident "normal"] = Pattern' <$> seti "slant" Strong 0 self
    longhand _ (Pattern' self) "font-style" [Ident "italic"] = Pattern' <$> seti "slant" Strong 100 self
    longhand _ (Pattern' self) "font-style" [Ident "oblique"] = Pattern' <$> seti "slant" Strong 110 self

    -- Conversion between CSS scale & FontConfig scale is non-trivial, use lookuptable.
    -- FIXME: Use Graphics.Text.Font.Choose.Weight!
    longhand _ (Pattern' self) "font-weight" [tok]
        | Just x <- parseFontWeight tok = Pattern' <$> 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 _ (Pattern' self) "font-weight" [Ident "lighter"]
        | Just ((_, ValueInt x):_) <- M.lookup "weight" self, x > 200 =
            Pattern' <$> seti "weight" Strong 200 self
        -- minus 100 adhears to the CSS standard awefully well in this new scale.
        | Just ((_, ValueInt x):_) <- M.lookup "weight" self =
            Pattern' <$> seti "weight" Strong (max (x - 100) 0) self
        | otherwise = Pattern' <$> seti "weight" Strong 0 self
    longhand _ self'@(Pattern' self) "font-weight" [Ident "bolder"]
        | Just ((_, ValueInt x):_) <- M.lookup "weight" self, x <= 65 =
            Pattern' <$> seti "weight" Strong 80 self
        | Just ((_, ValueInt x):_) <- M.lookup "weight" self, x <= 150 =
            Pattern' <$> seti "weight" Strong 200 self
        | Just ((_, ValueInt x):_) <- M.lookup "weight" self, x < 210 =
            Pattern' <$> seti "weight" Strong 210 self
        | Just ((_, ValueInt _):_) <- M.lookup "weight" self = Just self' -- As bold as it goes...
        | otherwise = Pattern' <$> seti "weight" Strong 200 self

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

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

    longhand _ (Pattern' s) "font-stretch" [tok]
        | Just x <- parseFontStretch tok = Pattern' <$> seti "width" Strong x s

    longhand _ _ _ _ = Nothing