module Graphics.SVGFonts.WriteFont where 

import Numeric ( showHex )

import Data.String ( fromString )
import Data.Char ( ord )
import Data.List ( intercalate )
import qualified Data.Set as Set
import qualified Data.Map as M

import Control.Monad ( forM_ )

import Text.Blaze.Svg11 ((!), toValue)
import qualified Text.Blaze.Internal as B
import qualified Text.Blaze.Svg11 as S
import qualified Text.Blaze.Svg11.Attributes as A

import Graphics.SVGFonts.ReadFont

makeSvgFont :: (Show n, S.ToValue n) => PreparedFont n -> Set.Set String -> S.Svg
makeSvgFont :: PreparedFont n -> Set String -> Svg
makeSvgFont (FontData n
fd, OutlineMap n
_) Set String
gs =
  Svg -> Svg
font (Svg -> Svg) -> Attribute -> Svg -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.horizAdvX AttributeValue
horizAdvX (Svg -> Svg) -> Svg -> Svg
forall a b. (a -> b) -> a -> b
$ do
    -- Font meta information
    Svg
S.fontFace Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.fontFamily AttributeValue
fontFamily
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.fontStyle AttributeValue
fontStyle
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.fontWeight AttributeValue
fontWeight
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.fontStretch AttributeValue
fontStretch
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.fontVariant AttributeValue
fontVariant
               # maybeMaybe A.fontSize fontDataSize
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.unitsPerEm AttributeValue
unitsPerEm
               # maybeString A.panose1 fontDataPanose
               # maybeMaybe A.slope fontDataSlope
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.ascent AttributeValue
ascent
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.descent AttributeValue
descent
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.xHeight AttributeValue
xHeight
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.capHeight AttributeValue
capHeight
               # maybeMaybe A.accentHeight fontDataAccentHeight
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.bbox AttributeValue
bbox
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.underlineThickness AttributeValue
underlineT
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.underlinePosition AttributeValue
underlineP
               Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.unicodeRange AttributeValue
unicodeRange
               # maybeMaybe A.widths fontDataWidths
               # maybeMaybe A.stemv  fontDataHorizontalStem
               # maybeMaybe A.stemh  fontDataVerticalStem
               # maybeMaybe A.ideographic   fontDataIdeographicBaseline
               # maybeMaybe A.alphabetic    fontDataAlphabeticBaseline
               # maybeMaybe A.mathematical  fontDataMathematicalBaseline
               # maybeMaybe A.hanging       fontDataHangingBaseline
               # maybeMaybe A.vIdeographic  fontDataVIdeographicBaseline
               # maybeMaybe A.vAlphabetic   fontDataVAlphabeticBaseline
               # maybeMaybe A.vMathematical fontDataVMathematicalBaseline
               # maybeMaybe A.vHanging      fontDataVHangingBaseline
               # maybeMaybe A.overlinePosition  fontDataOverlinePos
               # maybeMaybe A.overlineThickness fontDataOverlineThickness
               # maybeMaybe A.strikethroughPosition  fontDataStrikethroughPos
               # maybeMaybe A.strikethroughThickness fontDataStrikethroughThickness
    -- Insert the 'missing-glyph'
    case String
-> Map String (String, n, String) -> Maybe (String, n, String)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
".notdef" (FontData n -> Map String (String, n, String)
forall n. FontData n -> SvgGlyphs n
fontDataGlyphs FontData n
fd) of
      Maybe (String, n, String)
Nothing -> () -> Svg
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just (String
_, n
_, String
gPath) -> Svg -> Svg
S.missingGlyph (Svg -> Svg) -> Attribute -> Svg -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.d (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue String
gPath) 
                                           (Svg -> Svg) -> Svg -> Svg
forall a b. (a -> b) -> a -> b
$ () -> Svg
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    -- Insert all other glyphs
    [String] -> (String -> Svg) -> Svg
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
gs') ((String -> Svg) -> Svg) -> (String -> Svg) -> Svg
forall a b. (a -> b) -> a -> b
$ \String
g -> case String
-> Map String (String, n, String) -> Maybe (String, n, String)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
g (FontData n -> Map String (String, n, String)
forall n. FontData n -> SvgGlyphs n
fontDataGlyphs FontData n
fd) of
      Maybe (String, n, String)
Nothing -> () -> Svg
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just (String
gName, n
gHAdv, String
gPath) ->
        Svg -> Svg
S.glyph (Svg -> Svg) -> Attribute -> Svg -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.glyphName (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue String
gName)
                (Svg -> Svg) -> Attribute -> Svg -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.horizAdvX (n -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue n
gHAdv)
                (Svg -> Svg) -> Attribute -> Svg -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.d (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue String
gPath) 
                # maybeUnicode g
                (Svg -> Svg) -> Svg -> Svg
forall a b. (a -> b) -> a -> b
$ () -> Svg
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    
    [(String, [String], [String], [String], [String])]
-> ((String, [String], [String], [String], [String]) -> Svg) -> Svg
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (FontData n -> [(String, [String], [String], [String], [String])]
forall n.
FontData n -> [(String, [String], [String], [String], [String])]
fontDataRawKernings FontData n
fd) (((String, [String], [String], [String], [String]) -> Svg) -> Svg)
-> ((String, [String], [String], [String], [String]) -> Svg) -> Svg
forall a b. (a -> b) -> a -> b
$ \(String
k, [String]
g1, [String]
g2, [String]
u1, [String]
u2) -> do
      let g1' :: [String]
g1' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isGlyph [String]
g1
          g2' :: [String]
g2' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isGlyph [String]
g2
          u1' :: [String]
u1' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isGlyph [String]
u1
          u2' :: [String]
u2' = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isGlyph [String]
u2
      case (Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
g1') Bool -> Bool -> Bool
&& Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
g2')) Bool -> Bool -> Bool
|| (Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
u1') Bool -> Bool -> Bool
&& Bool -> Bool
not ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
u2')) of
        Bool
True ->
          Svg
S.hkern Svg -> Attribute -> Svg
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.k (String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue String
k)
                  # maybeString A.g1 (const $ intercalate "," g1')
                  # maybeString A.g2 (const $ intercalate "," g2')
                  # maybeString A.u1 (const $ intercalate "," u1')
                  # maybeString A.u2 (const $ intercalate "," u2')
        Bool
False -> () -> Svg
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  
  where
    (#) :: (B.Attributable h) => h -> Maybe S.Attribute -> h
    # :: h -> Maybe Attribute -> h
(#) h
x Maybe Attribute
Nothing = h
x
    (#) h
x (Just Attribute
a) = h
x h -> Attribute -> h
forall h. Attributable h => h -> Attribute -> h
! Attribute
a
    
    unicodeBlacklist :: Set.Set String
    unicodeBlacklist :: Set String
unicodeBlacklist = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList 
      [ String
".notdef"
      , String
".null"
      ]
    
    maybeUnicode :: String -> Maybe S.Attribute
    maybeUnicode :: String -> Maybe Attribute
maybeUnicode [] = Maybe Attribute
forall a. Maybe a
Nothing
    maybeUnicode String
s | String
s String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
unicodeBlacklist Bool -> Bool -> Bool
|| String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10 = Maybe Attribute
forall a. Maybe a
Nothing
    maybeUnicode String
s = Attribute -> Maybe Attribute
forall a. a -> Maybe a
Just (Attribute -> Maybe Attribute) -> Attribute -> Maybe Attribute
forall a b. (a -> b) -> a -> b
$ AttributeValue -> Attribute
A.unicode (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
encodeUnicode String
s
    
    encodeUnicode :: Char -> String
    encodeUnicode :: Char -> String
encodeUnicode Char
c = 
      let cOrd :: Int
cOrd = Char -> Int
ord Char
c
      in if Int
cOrd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
32 Bool -> Bool -> Bool
&& Int
cOrd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
126 
            then [Char
c] 
            else String
"&#x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex Int
cOrd String
""
    
    -- maybeMaybe :: (S.ToValue a) 
    --            => (S.AttributeValue -> S.Attribute) -> (FontData n -> Maybe a) 
    --            -> Maybe S.Attribute
    maybeMaybe :: (AttributeValue -> b) -> (FontData n -> f a) -> f b
maybeMaybe AttributeValue -> b
toF FontData n -> f a
fromF = (AttributeValue -> b
toF (AttributeValue -> b) -> (a -> AttributeValue) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue) (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FontData n -> f a
fromF FontData n
fd
    
    -- maybeString :: (S.AttributeValue -> S.Attribute) -> (FontData n -> String) 
    --             -> Maybe S.Attribute
    maybeString :: (AttributeValue -> a) -> (FontData n -> String) -> Maybe a
maybeString AttributeValue -> a
toF FontData n -> String
fromF = case FontData n -> String
fromF FontData n
fd of
      String
"" -> Maybe a
forall a. Maybe a
Nothing
      String
s -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ AttributeValue -> a
toF (AttributeValue -> a) -> AttributeValue -> a
forall a b. (a -> b) -> a -> b
$ String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ String
s
    
    font :: S.Svg -> S.Svg
    font :: Svg -> Svg
font Svg
m = StaticString -> StaticString -> StaticString -> Svg -> Svg
forall a.
StaticString
-> StaticString -> StaticString -> MarkupM a -> MarkupM a
B.Parent (String -> StaticString
forall a. IsString a => String -> a
fromString String
"font") (String -> StaticString
forall a. IsString a => String -> a
fromString String
"<font") (String -> StaticString
forall a. IsString a => String -> a
fromString String
"</font>") Svg
m
    
    isGlyph :: String -> Bool
    isGlyph :: String -> Bool
isGlyph String
g = String
g String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
gs'
    
    gs' :: Set String
gs' = String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
".notdef" Set String
gs
    
    horizAdvX :: AttributeValue
horizAdvX = n -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (n -> AttributeValue) -> n -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> n
forall n. FontData n -> n
fontDataHorizontalAdvance FontData n
fd
    fontFamily :: AttributeValue
fontFamily = String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> String
forall n. FontData n -> String
fontDataFamily FontData n
fd
    fontStyle :: AttributeValue
fontStyle = String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> String
forall n. FontData n -> String
fontDataStyle FontData n
fd
    fontWeight :: AttributeValue
fontWeight = String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> String
forall n. FontData n -> String
fontDataWeight FontData n
fd
    fontStretch :: AttributeValue
fontStretch = String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> String
forall n. FontData n -> String
fontDataStretch FontData n
fd
    fontVariant :: AttributeValue
fontVariant = String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> String
forall n. FontData n -> String
fontDataVariant FontData n
fd
    unitsPerEm :: AttributeValue
unitsPerEm = n -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (n -> AttributeValue) -> n -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> n
forall n. FontData n -> n
fontDataUnitsPerEm FontData n
fd 
    ascent :: AttributeValue
ascent = n -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (n -> AttributeValue) -> n -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> n
forall n. FontData n -> n
fontDataAscent FontData n
fd
    descent :: AttributeValue
descent = n -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (n -> AttributeValue) -> n -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> n
forall n. FontData n -> n
fontDataDescent FontData n
fd
    xHeight :: AttributeValue
xHeight = n -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (n -> AttributeValue) -> n -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> n
forall n. FontData n -> n
fontDataXHeight FontData n
fd
    capHeight :: AttributeValue
capHeight = n -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (n -> AttributeValue) -> n -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> n
forall n. FontData n -> n
fontDataCapHeight FontData n
fd
    bbox :: AttributeValue
bbox = String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (n -> String) -> [n] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n -> String
forall a. Show a => a -> String
show ([n] -> [String]) -> [n] -> [String]
forall a b. (a -> b) -> a -> b
$ FontData n -> [n]
forall n. FontData n -> [n]
fontDataBoundingBox FontData n
fd
    underlineT :: AttributeValue
underlineT = n -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (n -> AttributeValue) -> n -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> n
forall n. FontData n -> n
fontDataUnderlineThickness FontData n
fd
    underlineP :: AttributeValue
underlineP = n -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (n -> AttributeValue) -> n -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> n
forall n. FontData n -> n
fontDataUnderlinePos FontData n
fd
    unicodeRange :: AttributeValue
unicodeRange = String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FontData n -> String
forall n. FontData n -> String
fontDataUnicodeRange FontData n
fd