SVGFonts 1.3.0.2 → 1.4

raw patch · 4 files changed

+233/−31 lines, 4 filesdep +blaze-markupdep +blaze-svgPVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-markup, blaze-svg

API changes (from Hackage documentation)

Files

• SVGFonts.cabal +4/−1
• src/Graphics/SVGFonts/ReadFont.hs +81/−21
• src/Graphics/SVGFonts/ReadPath.hs +4/−9
• src/Graphics/SVGFonts/WriteFont.hs +144/−0

@@ -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 (<http://projects.haskell.org/diagrams/>). 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

@@ -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:                       --                       --   <<diagrams/textH.svg#diagram=textH&width=400>>-          | 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:                       --                       -- <<diagrams/textW.svg#diagram=textW&width=400>>@@ -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") 

@@ -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

@@ -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 "<font") (fromString "</font>") 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+