Pattern.hs

{-# LANGUAGE DeriveGeneric, CApiFFI #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Dynamically-typed datastructure describing a font, whether resolved or a query.
-- Can be parsed from CSS.
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(..), parseUnorderedShorthand', parseOperands)
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.Text (Text, unpack)
import qualified Data.Text as Txt
import Data.List (intercalate)
import Data.Scientific (toRealFloat)
import Data.Maybe as Mb (listToMaybe, fromMaybe, mapMaybe)
import Data.Char (isAscii)
import Prelude as L

-- | Holds both patterns to match against the available fonts, as well as the information about each font.
type Pattern = M.Map Text [(Binding, Value)]
-- | Wrapper around `Pattern` supporting useful typeclasses.
data Pattern' = Pattern' { unPattern :: Pattern } deriving (Eq, Read, Show, Generic)
-- | The precedance for a field of a Pattern.
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!

-- | Does the pattern hold a value we can process?
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)
-- | Variant of `validPattern` which applies to the `Pattern'` wrapper.
validPattern' :: Pattern' -> Bool
validPattern' = validPattern . unPattern

-- | Replace a field with a singular type-casted value.
setValue :: ToValue v => Text -> Binding -> v -> Pattern -> Pattern
setValue key strength v self = setValues key strength [v] self
-- | Replace a field with multiple type-casted values.
setValues :: ToValue v => Text -> Binding -> [v] -> Pattern -> Pattern
setValues key strength vs self = M.insert key [(strength, toValue v) | v <- vs] self

-- | Retrieve a field's primary type-casted value.
getValue :: ToValue v => Text -> Pattern -> Maybe v
getValue key self = fromValue . snd =<< listToMaybe =<< M.lookup key self
-- | Retrieve a field's type-casted values.
getValues :: ToValue v => Text -> Pattern -> [v]
getValues key self = Mb.mapMaybe (fromValue . snd) $ fromMaybe [] $ M.lookup key self

-- | Returns whether the given patterns have exactly the same values for all of the given objects.
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

-- | Supplies default values for underspecified font patterns:
-- Patterns without a specified style or weight are set to Medium
-- Patterns without a specified style or slant are set to Roman
-- Patterns without a specified pixel size are given one computed from any specified point size (default 12), dpi (default 75) and scale (default 1).
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

-- | Converts name from the standard text format described above into a pattern.
nameParse :: String -> Pattern
nameParse = fromMessage0 . withCString' fcNameParse

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

-- | Converts the given pattern into the standard text format described above.
nameUnparse :: Pattern -> String
nameUnparse a | validPattern a = peekCString' $ withMessage fcNameUnparse a
    | otherwise = ""

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

-- | Format a pattern into a string according to a format specifier
-- See https://fontconfig.pages.freedesktop.org/fontconfig/fontconfig-devel/fcpatternformat.html for full details.
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)], L.null toks', toks')
    Ident "off":Comma:toks' -> let (f, b, t) = parseFontFeatures toks' in ((feature, 1):f, b, t)
    Ident "off":toks' -> ([(feature, 1)], L.null toks', 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)], L.null toks', toks')
    _ -> ([(feature, 1)], L.null toks, toks)
parseFontFeatures toks = ([], False, toks)

-- | Parse OpenType variables from CSS syntax.
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

-- | Parse the CSS font-stretch property.
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.
-- | Parse the CSS font-weight property.
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 "%"]
    -- NOTE: Approximate implementation, caller should supply a real one!
    longhand (Pattern' super) (Pattern' self) "font-size" [Ident x] =
        let y = 10 :: Double in Pattern' <$> case x of
            -- NOTE: If a caller wants to be more precise about the base size (a.k.a `y`)
            -- they should parse it themselves!
            "xx-small" -> set "size" Strong (3/5*y) self
            "x-small" -> set "size" Strong (3/4*y) self
            "small" -> set "size" Strong (8/9*y) self
            "medium" -> set "size" Strong y self
            "large" -> set "size" Strong (6/5*y) self
            "x-large" -> set "size" Strong (3/2*y) self
            "xx-large" -> set "size" Strong (2*y) self
            "xxx-large" -> set "size" Strong (3*y) self
            -- NOTE: Spec encourages a more complex formula, caller should implement!
            "smaller" -> set "size" Strong (getSize super/1.2) self
            "larger" -> set "size" Strong (getSize super*1.2) self
            _ -> Nothing

    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
    longhand _ (Pattern' self) "font-style" [Ident "oblique", Dimension _ _ unit]
        | unit `elem` Txt.words "deg grad rad turn" = 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' <$>
            sets "fontfeatures" Strong (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
        | (vars , True, []) <- parseFontVars toks =
            Pattern' <$> (set "variable" Strong True =<<
                set "fontvariations" Strong (intercalate "," $ L.map fst vars) self)

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

    longhand _ _ _ _ = Nothing

    shorthand self "font" toks = case parseOperands toks of
        (a:b:c:d:toks') | ret@(_:_) <- unordered [a,b,c,d] -> inner ret toks'
        (a:b:c:toks') | ret@(_:_) <- unordered [a,b,c] -> inner ret toks'
        (a:b:toks') | ret@(_:_) <- unordered [a,b] -> inner ret toks'
        (a:toks') | ret@(_:_) <- unordered [a] -> inner ret toks'
        toks' -> inner [] toks'
      where
        unordered operands =
          let ret = parseUnorderedShorthand' self [
                        "font-style", "font-variant", "font-weight", "font-stretch"
                    ] operands
          in if ("", []) `elem` ret then [] else ret -- Check for errors!
        inner ret (sz:[Delim '/']:height:family)
            | Just _ <- longhand self self "font-size" sz,
              Just _ <- longhand self self "line-height" height,
              Just _ <- longhand self self "font-family" $ concat family =
                ("font-size", sz):("line-height", height):
                    ("font-family", concat family):ret
            | otherwise = []
        inner ret (sz:family)
            | Just _ <- longhand self self "font-size" sz,
              Just _ <- longhand self self "font-family" $ concat family =
                ("font-size", sz):("line-height", [Ident "initial"]):
                    ("font-family", concat family):ret
            | otherwise = []
        inner _ _ = []

    shorthand self k v | Just _ <- longhand self self k v = [(k, v)]
        | otherwise = []