diff --git a/SVGFonts.cabal b/SVGFonts.cabal
--- a/SVGFonts.cabal
+++ b/SVGFonts.cabal
@@ -1,5 +1,5 @@
Name: SVGFonts
-Version: 1.3.0.2
+Version: 1.4
Synopsis: Fonts from the SVG-Font format
Description: Native font support for the diagrams framework (). Note that this package can be used with any diagrams backend, not just the SVG backend. The SVG-tont format is easy to parse
and was therefore chosen for a font library completely written in Haskell.
@@ -63,6 +63,8 @@
data-default-class < 0.1,
diagrams-lib >= 0.7 && < 0.8,
directory >= 1.1,
+ blaze-svg >= 0.3.3,
+ blaze-markup >= 0.5,
parsec,
split,
text,
@@ -75,4 +77,5 @@
Graphics.SVGFonts.ReadFont
Graphics.SVGFonts.CharReference
Graphics.SVGFonts.ReadPath
+ Graphics.SVGFonts.WriteFont
default-language: Haskell2010
diff --git a/src/Graphics/SVGFonts/ReadFont.hs b/src/Graphics/SVGFonts/ReadFont.hs
--- a/src/Graphics/SVGFonts/ReadFont.hs
+++ b/src/Graphics/SVGFonts/ReadFont.hs
@@ -142,22 +142,42 @@
, fontDataFileName :: String
, fontDataUnderlinePos :: Double
, fontDataUnderlineThickness :: Double
+ , fontDataOverlinePos :: Maybe Double
+ , fontDataOverlineThickness :: Maybe Double
+ , fontDataStrikethroughPos :: Maybe Double
+ , fontDataStrikethroughThickness :: Maybe Double
, fontDataHorizontalAdvance :: Double
, fontDataFamily :: String
- , fontDataWeight :: Double
+ , fontDataStyle :: String
+ , fontDataWeight :: String
+ , fontDataVariant :: String
, fontDataStretch :: String
+ , fontDataSize :: Maybe String
, fontDataUnitsPerEm :: Double
, fontDataPanose :: String
+ , fontDataSlope :: Maybe Double
, fontDataAscent :: Double
, fontDataDescent :: Double
, fontDataXHeight :: Double
, fontDataCapHeight :: Double
- , fontDataHorizontalStem :: Double
- , fontDataVerticalStem :: Double
+ , fontDataAccentHeight :: Maybe Double
+ , fontDataWidths :: Maybe String
+ , fontDataHorizontalStem :: Maybe Double
+ -- ^ This data is not available in some fonts (e.g. Source Code Pro)
+ , fontDataVerticalStem :: Maybe Double
+ -- ^ This data is not available in some fonts (e.g. Source Code Pro)
, fontDataUnicodeRange :: String
+ , fontDataRawKernings :: [(String, [String], [String], [String], [String])]
+ , fontDataIdeographicBaseline :: Maybe Double
+ , fontDataAlphabeticBaseline :: Maybe Double
+ , fontDataMathematicalBaseline :: Maybe Double
+ , fontDataHangingBaseline :: Maybe Double
+ , fontDataVIdeographicBaseline :: Maybe Double
+ , fontDataVAlphabeticBaseline :: Maybe Double
+ , fontDataVMathematicalBaseline :: Maybe Double
+ , fontDataVHangingBaseline :: Maybe Double
+ -- ^ (k, g1, g2, u1, u2)
} deriving Show
---type FontData = (SvgGlyph, Kern, [Double], String, (Double, Double),
--- (Double,String,Double,String,Double,String,Double,Double,Double,Double,Double,Double,String))
-- | Open an SVG-Font File and extract the data
--
@@ -176,36 +196,61 @@
, fontDataUnderlinePos = fontface `readAttr` "underline-position"
, fontDataUnderlineThickness = fontface `readAttr` "underline-thickness"
, fontDataHorizontalAdvance = fontHadv
- , fontDataFamily = fontFamily
- , fontDataWeight = fontface `readAttr` "font-weight"
- , fontDataStretch = fontStretch
+ , fontDataFamily = readString fontface "font-family" ""
+ , fontDataStyle = readString fontface "font-style" "all"
+ , fontDataWeight = readString fontface "font-weight" "all"
+ , fontDataVariant = readString fontface "font-variant" "normal"
+ , fontDataStretch = readString fontface "font-stretch" "normal"
+ , fontDataSize = fontface `readStringM` "font-size"
, fontDataUnitsPerEm = fontface `readAttr` "units-per-em"
- , fontDataPanose = panose
+ , fontDataSlope = fontface `readAttrM` "slope"
+ , fontDataPanose = readString fontface "panose-1" "0 0 0 0 0 0 0 0 0 0"
, fontDataAscent = fontface `readAttr` "ascent"
, fontDataDescent = fontface `readAttr` "descent"
, fontDataXHeight = fontface `readAttr` "x-height"
, fontDataCapHeight = fontface `readAttr` "cap-height"
- , fontDataHorizontalStem = fontface `readAttr` "stemh"
- , fontDataVerticalStem = fontface `readAttr` "stemv"
- , fontDataUnicodeRange = unicodeRange
+ , fontDataAccentHeight = fontface `readAttrM` "accent-height"
+ , fontDataWidths = fontface `readStringM` "widths"
+ , fontDataHorizontalStem = fontface `readAttrM` "stemh"
+ , fontDataVerticalStem = fontface `readAttrM` "stemv"
+ , fontDataUnicodeRange = readString fontface "unicode-range" "U+0-10FFFF"
+ , fontDataRawKernings = rawKerns
+ , fontDataIdeographicBaseline = fontface `readAttrM` "ideographic"
+ , fontDataAlphabeticBaseline = fontface `readAttrM` "alphabetic"
+ , fontDataMathematicalBaseline = fontface `readAttrM` "mathematical"
+ , fontDataHangingBaseline = fontface `readAttrM` "hanging"
+ , fontDataVIdeographicBaseline = fontface `readAttrM` "v-ideographic"
+ , fontDataVAlphabeticBaseline = fontface `readAttrM` "v-alphabetic"
+ , fontDataVMathematicalBaseline = fontface `readAttrM` "v-mathematical"
+ , fontDataVHangingBaseline = fontface `readAttrM` "v-hanging"
+ , fontDataOverlinePos = fontface `readAttrM` "overline-position"
+ , fontDataOverlineThickness = fontface `readAttrM` "overline-thickness"
+ , fontDataStrikethroughPos = fontface `readAttrM` "strikethrough-position"
+ , fontDataStrikethroughThickness = fontface `readAttrM` "strikethrough-thickness"
}
where
readAttr :: (Read a) => Element -> String -> a
readAttr element attr = fromJust $ fmap read $ findAttr (unqual attr) element
+ readAttrM :: (Read a) => Element -> String -> Maybe a
+ readAttrM element attr = fmap read $ findAttr (unqual attr) element
+
+ -- | @readString e a d@ : @e@ element to read from; @a@ attribute to read; @d@ default value.
+ readString :: Element -> String -> String -> String
+ readString element attr d = fromMaybe d $ findAttr (unqual attr) element
+
+ readStringM :: Element -> String -> Maybe String
+ readStringM element attr = findAttr (unqual attr) element
+
xml = onlyElems $ parseXML $ unsafePerformIO $ readFile file
fontElement = head $ catMaybes $ map (findElement (unqual "font")) xml
fontHadv = fromMaybe ((parsedBBox!!2) - (parsedBBox!!0)) -- BBox is used if there is no "horiz-adv-x" attribute
(fmap read (findAttr (unqual "horiz-adv-x") fontElement) )
fontface = fromJust $ findElement (unqual "font-face") fontElement -- there is always a font-face node
- bbox = fromMaybe "" $ findAttr (unqual "bbox") fontface
+ bbox = readString fontface "bbox" ""
parsedBBox :: [Double]
parsedBBox = map read $ splitWhen isSpace bbox
- fontFamily = fromMaybe "" $ findAttr (unqual "font-family") fontface
- fontStretch = fromMaybe "" $ findAttr (unqual "font-stretch") fontface
- panose = fromMaybe "" $ findAttr (unqual "panose-1") fontface
- unicodeRange = fromMaybe "" $ findAttr (unqual "unicode-range") fontface
glyphElements = findChildren (unqual "glyph") fontElement
kernings = findChildren (unqual "hkern") fontElement
@@ -227,6 +272,15 @@
g2s = map (fromMaybe "") $ map (findAttr (unqual "g2")) kernings
ks = map (fromMaybe "") $ map (findAttr (unqual "k")) kernings
kAr = V.fromList (map read ks)
+
+ rawKerns = fmap getRawKern kernings
+ getRawKern kerning =
+ let u1 = splitWhen (==',') $ fromMaybe "" $ findAttr (unqual "u1") $ kerning
+ u2 = splitWhen (==',') $ fromMaybe "" $ findAttr (unqual "u2") $ kerning
+ g1 = splitWhen (==',') $ fromMaybe "" $ findAttr (unqual "g1") $ kerning
+ g2 = splitWhen (==',') $ fromMaybe "" $ findAttr (unqual "g2") $ kerning
+ k = fromMaybe "" $ findAttr (unqual "k") $ kerning
+ in (k, g1, g2, u1, u2)
transformChars chars = Map.fromList $ map ch $ multiSet $
map (\(x,y) -> (x,[y])) $ sort fst $ concat $ index chars
@@ -321,8 +375,8 @@
-- The result can be smaller or bigger than the bounding box:
--
-- <>
- | INSIDE_W -- ^ The string fills the complete width, heigth adjusted.
- -- Maybe useful for single words in a diagram or headlines.
+ | INSIDE_W -- ^ The string fills the complete width, height adjusted.
+ -- May be useful for single words in a diagram, or for headlines.
-- The result can be smaller or bigger than the bounding box:
--
-- <>
@@ -462,7 +516,12 @@
go ( A_rel ) = Nothing
commands :: String -> SvgGlyphs -> [PathCommand]
-commands ch glyph | isJust element = unsafePerformIO $ pathFromString $ sel3 $ fromJust element
+commands ch glyph | isJust element = case pathFromString (sel3 $ fromJust element) of
+ Left err -> unsafePerformIO $ do
+ putStr "parse error at "
+ print err
+ return []
+ Right p -> p
| otherwise = []
where element = Map.lookup ch glyph
@@ -474,7 +533,8 @@
lin :: (FontData, OutlineMap)
lin = outlMap (ro "fonts/LinLibertine.svg")
--- | Linux Libertine, cut to the most common Characters, smaller file, quicker load time
+-- | Linux Libertine, cut to contain only the most common characters,
+-- resulting in a smaller file and hence a quicker load time.
lin2 :: (FontData, OutlineMap)
lin2 = outlMap (ro "fonts/LinLibertineCut.svg")
diff --git a/src/Graphics/SVGFonts/ReadPath.hs b/src/Graphics/SVGFonts/ReadPath.hs
--- a/src/Graphics/SVGFonts/ReadPath.hs
+++ b/src/Graphics/SVGFonts/ReadPath.hs
@@ -55,15 +55,10 @@
deriving Show
-- | Convert a SVG path string into a list of commands
-pathFromString :: String -> IO [PathCommand]
-pathFromString str
- = do{ case (parse path "" str) of
- Left err -> do{ putStr "parse error at "
- ; print err
- ; return []
- }
- Right x -> return x
- }
+pathFromString :: String -> Either String [PathCommand]
+pathFromString str = case parse path "" str of
+ Left err -> Left (show err)
+ Right p -> Right p
spaces :: Parser ()
spaces = skipMany space
diff --git a/src/Graphics/SVGFonts/WriteFont.hs b/src/Graphics/SVGFonts/WriteFont.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/SVGFonts/WriteFont.hs
@@ -0,0 +1,144 @@
+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 :: (FontData, OutlineMap) -> Set.Set String -> S.Svg
+makeSvgFont (fd, _) gs = do
+ font ! A.horizAdvX horizAdvX $ do
+ -- Font meta information
+ S.fontFace ! A.fontFamily fontFamily
+ ! A.fontStyle fontStyle
+ ! A.fontWeight fontWeight
+ ! A.fontStretch fontStretch
+ ! A.fontVariant fontVariant
+ # maybeMaybe A.fontSize fontDataSize
+ ! A.unitsPerEm unitsPerEm
+ # maybeString A.panose1 fontDataPanose
+ # maybeMaybe A.slope fontDataSlope
+ ! A.ascent ascent
+ ! A.descent descent
+ ! A.xHeight xHeight
+ ! A.capHeight capHeight
+ # maybeMaybe A.accentHeight fontDataAccentHeight
+ ! A.bbox bbox
+ ! A.underlineThickness underlineT
+ ! A.underlinePosition underlineP
+ ! A.unicodeRange 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 M.lookup ".notdef" (fontDataGlyphs fd) of
+ Nothing -> return ()
+ Just (_, _, gPath) -> S.missingGlyph ! A.d (toValue gPath)
+ $ return ()
+ -- Insert all other glyphs
+ forM_ (Set.toList gs') $ \g -> case M.lookup g (fontDataGlyphs fd) of
+ Nothing -> return ()
+ Just (gName, gHAdv, gPath) -> do
+ S.glyph ! A.glyphName (toValue gName)
+ ! A.horizAdvX (toValue gHAdv)
+ ! A.d (toValue gPath)
+ # maybeUnicode g
+ $ return ()
+ let
+ forM_ (fontDataRawKernings fd) $ \(k, g1, g2, u1, u2) -> do
+ let g1' = filter isGlyph g1
+ g2' = filter isGlyph g2
+ u1' = filter isGlyph u1
+ u2' = filter isGlyph u2
+ case (not (null g1') && not (null g2')) || (not (null u1') && not (null u2')) of
+ True -> do
+ S.hkern ! A.k (toValue 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')
+ False -> return ()
+
+
+ where
+ (#) :: (B.Attributable h) => h -> Maybe S.Attribute -> h
+ (#) x Nothing = x
+ (#) x (Just a) = x ! a
+
+ unicodeBlacklist :: Set.Set String
+ unicodeBlacklist = Set.fromList
+ [ ".notdef"
+ , ".null"
+ ]
+
+ maybeUnicode :: String -> Maybe S.Attribute
+ maybeUnicode [] = Nothing
+ maybeUnicode s | s `Set.member` unicodeBlacklist || length s >= 10 = Nothing
+ maybeUnicode s = Just $ A.unicode $ toValue $ concatMap encodeUnicode s
+
+ encodeUnicode :: Char -> String
+ encodeUnicode c =
+ let cOrd = ord c
+ in if cOrd >= 32 && cOrd <= 126
+ then [c]
+ else "&#x" ++ (showHex cOrd "")
+
+ maybeMaybe :: (S.ToValue a)
+ => (S.AttributeValue -> S.Attribute) -> (FontData -> Maybe a)
+ -> Maybe S.Attribute
+ maybeMaybe toF fromF = (toF . toValue) `fmap` fromF fd
+
+ maybeString :: (S.AttributeValue -> S.Attribute) -> (FontData -> String)
+ -> Maybe S.Attribute
+ maybeString toF fromF = case fromF fd of
+ "" -> Nothing
+ s -> Just $ toF $ toValue $ s
+
+ font :: S.Svg -> S.Svg
+ font m = B.Parent (fromString "font") (fromString "") m
+
+ isGlyph :: String -> Bool
+ isGlyph g = g `Set.member` gs'
+
+ gs' = Set.insert ".notdef" gs
+
+ horizAdvX = toValue $ fontDataHorizontalAdvance fd
+ fontFamily = toValue $ fontDataFamily fd
+ fontStyle = toValue $ fontDataStyle fd
+ fontWeight = toValue $ fontDataWeight fd
+ fontStretch = toValue $ fontDataStretch fd
+ fontVariant = toValue $ fontDataVariant fd
+ unitsPerEm = toValue $ fontDataUnitsPerEm fd
+ ascent = toValue $ fontDataAscent fd
+ descent = toValue $ fontDataDescent fd
+ xHeight = toValue $ fontDataXHeight fd
+ capHeight = toValue $ fontDataCapHeight fd
+ bbox = toValue $ intercalate " " $ fmap show $ fontDataBoundingBox fd
+ underlineT = toValue $ fontDataUnderlineThickness fd
+ underlineP = toValue $ fontDataUnderlinePos fd
+ unicodeRange = toValue $ fontDataUnicodeRange fd
+