diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +1.6 (8 August 2016) +------------------- + +- Performance improvement: port ReadPath to use attoparsec +- New `loadFont'` function, to read font data from an XmlSource +- Export `Kern(..)` from `Graphics.SVGFonts.ReadFont` +- New `Serialize` instances for `FontData` and `Kern` + 1.5.0.1 (6 June 2016) --------------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,12 @@ Copyright (c) 2013, SVGFonts team: + Daniel Bergey Jan Bracker + Christopher Chalmers + Ben Gamari + Gabor Greif + Niklas Hambüchen + Sidharth Kapur Chris Mears Jeffrey Rosenbluth Tillmann Vogt diff --git a/SVGFonts.cabal b/SVGFonts.cabal --- a/SVGFonts.cabal +++ b/SVGFonts.cabal @@ -1,5 +1,5 @@ Name: SVGFonts -Version: 1.5.0.1 +Version: 1.6.0.0 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-font format is easy to parse and was therefore chosen for a font library completely written in Haskell. @@ -48,7 +48,7 @@ data-files: fonts/*.svg extra-source-files: CHANGES.md, README.md, diagrams/*.svg extra-doc-files: diagrams/*.svg -Tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1 +Tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1 source-repository head type: git location: https://github.com/diagrams/SVGFonts.git @@ -60,6 +60,9 @@ build-depends: attoparsec, base == 4.*, + bytestring >= 0.10 && < 1.0, + cereal, + cereal-vector, containers >= 0.4 && < 0.6, data-default-class < 0.2, diagrams-core >= 1.3 && < 1.4, 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} module Graphics.SVGFonts.ReadFont ( FontData(..) @@ -10,10 +11,12 @@ , horizontalAdvance , kernAdvance + , Kern(..) , OutlineMap , PreparedFont , loadFont + , loadFont' ) where import Data.Char (isSpace) @@ -28,11 +31,16 @@ import Diagrams.Path import Diagrams.Prelude hiding (font) import Text.XML.Light +import Text.XML.Light.Lexer (XmlSource) import Graphics.SVGFonts.CharReference (charsFromFullName) import Graphics.SVGFonts.ReadPath (PathCommand (..), pathFromString) +import GHC.Generics (Generic) +import Data.Serialize (Serialize) +import Data.Vector.Serialize () + -- | This type contains everything that a typical SVG font file produced -- by fontforge contains. data FontData n = FontData @@ -76,18 +84,20 @@ , fontDataVAlphabeticBaseline :: Maybe n , fontDataVMathematicalBaseline :: Maybe n , fontDataVHangingBaseline :: Maybe n - } + } deriving (Generic) +instance Serialize n => Serialize (FontData n) + -- | Open an SVG-Font File and extract the data -parseFont :: (Read n, RealFloat n) => FilePath -> String -> FontData n -parseFont filename contents = readFontData fontElement filename +parseFont :: (XmlSource s, Read n, RealFloat n) => FilePath -> s -> FontData n +parseFont basename contents = readFontData fontElement basename where xml = onlyElems $ parseXML $ contents fontElement = head $ catMaybes $ map (findElement (unqual "font")) xml -- | Read font data from an XML font element. -readFontData :: (Read n, RealFloat n) => Element -> FilePath -> FontData n -readFontData fontElement file = FontData +readFontData :: (Read n, RealFloat n) => Element -> String -> FontData n +readFontData fontElement basename = FontData { fontDataGlyphs = Map.fromList glyphs , fontDataKerning = Kern { kernU1S = transformChars u1s @@ -97,7 +107,7 @@ , kernK = kAr } , fontDataBoundingBox = parsedBBox - , fontDataFileName = fname file + , fontDataFileName = basename , fontDataUnderlinePos = fontface `readAttr` "underline-position" , fontDataUnderlineThickness = fontface `readAttr` "underline-thickness" , fontDataHorizontalAdvance = fontHadv @@ -201,7 +211,6 @@ multiSet (a:b:bs) | fst a == fst b = multiSet ( (fst a, (snd a) ++ (snd b)) : bs) | otherwise = a : (multiSet (b:bs)) - fname f = last $ init $ concat (map (splitOn "/") (splitOn "." f)) type SvgGlyphs n = Map.Map String (String, n, String) @@ -234,8 +243,10 @@ , kernG1S :: Map.Map String [Int] , kernG2S :: Map.Map String [Int] , kernK :: V.Vector n - } deriving Show + } deriving (Show, Generic) +instance Serialize n => Serialize (Kern n) + -- | Change the horizontal advance of two consective chars (kerning) kernAdvance :: RealFloat n => String -> String -> Kern n -> Bool -> n kernAdvance ch0 ch1 kern u | u && not (null s0) = (kernK kern) V.! (head s0) @@ -325,12 +336,22 @@ -- | Read font data from font file, and compute its outline map. loadFont :: (Read n, RealFloat n) => FilePath -> IO (PreparedFont n) loadFont filename = do - fontData <- parseFont filename <$> readFile filename - let (font, errs) = prepareFont fontData - sequence_ [ putStrLn ("error parsing character '" ++ ch ++ "': " ++ err) - | (ch, err) <- Map.toList errs - ] - return font + s <- readFile filename + let + basename = last $ init $ concat (map (splitOn "/") (splitOn "." filename)) + (errors, font) = loadFont' basename s + putStrLn errors + return font + +-- | Read font data from an XmlSource, and compute its outline map. +loadFont' :: (XmlSource s, Read n, RealFloat n) => String -> s -> (String, PreparedFont n) +loadFont' basename s = + let + fontData = parseFont basename s + (font, errs) = prepareFont fontData + errors = unlines $ map (\(ch, err) -> "error parsing character '" ++ ch ++ "': " ++ err) (Map.toList errs) + in + (errors, font) commandsToTrails ::RealFloat n => [PathCommand n] -> [Segment Closed V2 n] -> V2 n -> V2 n -> V2 n -> [Path V2 n] commandsToTrails [] _ _ _ _ = [] 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 @@ -14,48 +14,51 @@ module Graphics.SVGFonts.ReadPath ( pathFromString, + pathFromByteString, PathCommand(..), ) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative hiding (many, (<|>)) -#endif +import Control.Applicative -import Text.ParserCombinators.Parsec hiding (spaces) -import Text.ParserCombinators.Parsec.Language (emptyDef) -import qualified Text.ParserCombinators.Parsec.Token as P +import qualified Data.Attoparsec.ByteString.Char8 as P +import Data.Attoparsec.ByteString.Char8 (Parser, skipMany, space, many1, try, char) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS data PathCommand n = - M_abs (n, n) | -- ^Establish a new current point (with absolute coords) - M_rel (n, n) | -- ^Establish a new current point (with coords relative to the current point) + M_abs !(n, n) | -- ^Establish a new current point (with absolute coords) + M_rel !(n, n) | -- ^Establish a new current point (with coords relative to the current point) Z | -- ^Close current subpath by drawing a straight line from current point to current subpath's initial point - L_abs (n, n) | -- ^A line from the current point to (n, n) which becomes the new current point - L_rel (n, n) | - H_abs n | -- ^A horizontal line from the current point (cpx, cpy) to (x, cpy) - H_rel n | - V_abs n | -- ^A vertical line from the current point (cpx, cpy) to (cpx, y) - V_rel n | - C_abs (n,n,n,n,n,n) | -- ^Draws a cubic Bézier curve from the current point to (x,y) using (x1,y1) as the + L_abs !(n, n) | -- ^A line from the current point to (n, n) which becomes the new current point + L_rel !(n, n) | + H_abs !n | -- ^A horizontal line from the current point (cpx, cpy) to (x, cpy) + H_rel !n | + V_abs !n | -- ^A vertical line from the current point (cpx, cpy) to (cpx, y) + V_rel !n | + C_abs !(n,n,n,n,n,n) | -- ^Draws a cubic Bézier curve from the current point to (x,y) using (x1,y1) as the -- ^control point at the beginning of the curve and (x2,y2) as the control point at the end of the curve. - C_rel (n,n,n,n,n,n) | - S_abs (n,n,n,n) | -- ^Draws a cubic Bézier curve from the current point to (x,y). The first control point is + C_rel !(n,n,n,n,n,n) | + S_abs !(n,n,n,n) | -- ^Draws a cubic Bézier curve from the current point to (x,y). The first control point is -- assumed to be the reflection of the second control point on the previous command relative to the current point. -- (If there is no previous command or if the previous command was not an C, c, S or s, assume the first control -- point is coincident with the current point.) (x2,y2) is the second control point (i.e., the control point at -- the end of the curve). - S_rel (n,n,n,n) | - Q_abs (n,n,n,n) | -- ^A quadr. Bézier curve from the curr. point to (x,y) using (x1,y1) as the control point - Q_rel (n,n,n,n) | -- ^Nearly the same as cubic, but with one point less - T_abs (n, n) | -- ^T_Abs = Shorthand/smooth quadratic Bezier curveto - T_rel (n, n) | + S_rel !(n,n,n,n) | + Q_abs !(n,n,n,n) | -- ^A quadr. Bézier curve from the curr. point to (x,y) using (x1,y1) as the control point + Q_rel !(n,n,n,n) | -- ^Nearly the same as cubic, but with one point less + T_abs !(n, n) | -- ^T_Abs = Shorthand/smooth quadratic Bezier curveto + T_rel !(n, n) | A_abs | -- ^A = Elliptic arc (not used) A_rel deriving Show -- | Convert a SVG path string into a list of commands pathFromString :: Fractional n => String -> Either String [PathCommand n] -pathFromString str = case parse path "" str of +pathFromString = pathFromByteString . BS.pack + +pathFromByteString :: Fractional n => ByteString -> Either String [PathCommand n] +pathFromByteString str = case P.parseOnly path str of Left err -> Left (show err) Right p -> Right p @@ -64,7 +67,7 @@ path :: Fractional n => Parser [PathCommand n] path = do{ l <- many pathElement - ; eof + ; P.endOfInput ; return (concat l) } @@ -119,14 +122,14 @@ try float <|> -- 0 is not recognized as a float, so recognize it as an integer and then convert to float do { i<-integer; return(fromIntegral i) } -lexer :: P.TokenParser a -lexer = P.makeTokenParser emptyDef - whiteSpace :: Parser () -whiteSpace = P.whiteSpace lexer -symbol :: String -> Parser String -symbol = P.symbol lexer +whiteSpace = P.skipSpace + +symbol :: String -> Parser () +symbol s = P.string (BS.pack s) >> whiteSpace + integer :: Parser Integer -integer = P.integer lexer +integer = P.decimal + float :: Fractional n => Parser n -float = realToFrac <$> P.float lexer +float = realToFrac <$> P.double