SVGFonts 1.6.0.3 → 1.7

raw patch · 6 files changed

+110/−66 lines, 6 filesdep −tupledep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies removed: tuple

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• CHANGES.md +8/−0
• SVGFonts.cabal +12/−10
• src/Graphics/SVGFonts.hs +2/−2
• src/Graphics/SVGFonts/Fonts.hs +10/−10
• src/Graphics/SVGFonts/ReadFont.hs +65/−39
• src/Graphics/SVGFonts/Text.hs +13/−5

@@ -1,3 +1,11 @@+1.7 (9 May 2018)+---------------------++- Fixed a bug (Fontforge seems to use SVG namespace for some time, which it didn't before)+- `unsafePerformIO` removed+- drop support for GHC 7.6+- Build with GHC-8.4+ 1.6.0.3 (25 September 2017) --------------------------- 

@@ -1,5 +1,5 @@ Name:             SVGFonts-Version:          1.6.0.3+Version:          1.7 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-font format is easy to parse                   and was therefore chosen for a font library completely written in Haskell.@@ -28,15 +28,18 @@                   .                   >  # LANGUAGE NoMonomorphismRestriction #                   >-                  > import Diagrams.Prelude-                  > import Diagrams.Backend.Rasterific.CmdLine-                  > import Graphics.SVGFonts+                  > main = do linLibertine <- loadDataFont "fonts/LinLibertine.svg"+                  >           t <- text'''' linLibertine "Hello"+                  >           mainWith (t :: Diagram B)                   >-                  > main = defaultMain (text' "Hello World")+                  > text'   font t = stroke (textSVG t 1) # fc purple # fillRule EvenOdd+                  > text''  font t = stroke (textSVG' (TextOpts font INSIDE_H KERN False 1 1) t) # fillRule EvenOdd+                  > text''' font t =        (textSVG_ (TextOpts font INSIDE_H KERN True  1 1) t) # fillRule EvenOdd                   >-                  > text'   t = stroke (textSVG t 1) # fc purple # fillRule EvenOdd-                  > text''  t = stroke (textSVG' (TextOpts lin INSIDE_H KERN False 1 1) t) # fillRule EvenOdd-                  > text''' t =        (textSVG_ (TextOpts lin INSIDE_H KERN True  1 1) t) # fillRule EvenOdd+                  > -- using a local font+                  > text'''' font t = do+                  >    font <- loadFont "/path/to/font.svg"+                  >    return $ stroke (textSVG' (TextOpts font INSIDE_H KERN False 1 1) t)                   . category:         Graphics License:          BSD3@@ -49,7 +52,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.2, GHC == 8.0.1, GHC == 8.2.1+Tested-with:      GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1, GHC == 8.2.1 source-repository head   type: git   location: https://github.com/diagrams/SVGFonts.git@@ -74,7 +77,6 @@         parsec,         split,         text,-        tuple,         vector,         xml     exposed-modules:

@@ -10,10 +10,10 @@     , bit, lin, lin2        -- * Loading fonts-    , loadFont+    , loadFont, loadDataFont     )     where  import Graphics.SVGFonts.Text-import Graphics.SVGFonts.Fonts    (bit, lin, lin2)+import Graphics.SVGFonts.Fonts    (bit, lin, lin2, loadDataFont) import Graphics.SVGFonts.ReadFont (loadFont)

@@ -1,34 +1,34 @@ module Graphics.SVGFonts.Fonts        ( -- * Built-in fonts-         bit, lin, lin2+         bit, lin, lin2, loadDataFont        ) where -import System.IO.Unsafe (unsafePerformIO)- import Graphics.SVGFonts.ReadFont (loadFont, PreparedFont) import Paths_SVGFonts (getDataFileName)  -- | Get full path of data file. -- Safe if package is installed correctly.-dataFile :: FilePath -> FilePath-dataFile = unsafePerformIO . getDataFileName+dataFile :: FilePath -> IO FilePath+dataFile = getDataFileName  -- | Load a font from a file in the data directory. loadDataFont :: (Read n, RealFloat n) =>-                FilePath -> PreparedFont n-loadDataFont = unsafePerformIO . loadFont . dataFile+                FilePath -> IO (PreparedFont n)+loadDataFont filepath =+  do f <- dataFile filepath+     loadFont f  -- | Bitstream, a standard monospaced font (used in gedit)-bit :: (Read n, RealFloat n) => PreparedFont n+bit :: (Read n, RealFloat n) => IO (PreparedFont n) bit = loadDataFont "fonts/Bitstream.svg"  -- | Linux Libertine, for non-monospaced text. --   <http://www.linuxlibertine.org/> --   Contains a lot of unicode characters.-lin :: (Read n, RealFloat n) => PreparedFont n+lin :: (Read n, RealFloat n) => IO (PreparedFont n) lin = loadDataFont "fonts/LinLibertine.svg"  -- | Linux Libertine, cut to contain only the most common characters. --   This results in a smaller file and hence a quicker load time.-lin2 :: (Read n, RealFloat n) => PreparedFont n+lin2 :: (Read n, RealFloat n) => IO (PreparedFont n) lin2 = loadDataFont "fonts/LinLibertineCut.svg"

@@ -27,7 +27,6 @@ import           Data.Maybe                      (catMaybes, fromJust,                                                   fromMaybe, isJust, isNothing,                                                   maybeToList)-import           Data.Tuple.Select import qualified Data.Vector                     as V import           Diagrams.Path import           Diagrams.Prelude                hiding (font)@@ -94,8 +93,16 @@ parseFont basename contents = readFontData fontElement basename   where     xml = onlyElems $ parseXML $ contents-    fontElement = head $ catMaybes $ map (findElement (unqual "font")) xml+    fontElement | null fontElements = error ("no <font>-tag found in SVG file using SVGFonts library." +++                                             "Most likely wrong namespace in <svg>-tag. Please delete xmlns=...")+                | otherwise = head $ catMaybes $ fontElements +    fontElements = map (findElement (qTag "font")) xml ++ -- sometimes there is a namespace given with <svg xmlns=...+                   map (findElement (unqual "font")) xml -- sometimes not: <svg>++qTag :: String -> QName+qTag name = QName {qName = name, qURI = Just "http://www.w3.org/2000/svg", qPrefix = Nothing}+ -- | Read font data from an XML font element. readFontData :: (Read n, RealFloat n) => Element -> String -> FontData n readFontData fontElement basename = FontData@@ -145,55 +152,67 @@   , fontDataStrikethroughThickness = fontface `readAttrM` "strikethrough-thickness"   }   where+    findAttr' attr e | isJust uq = uq+                     | otherwise = q+      where uq = findAttr (unqual attr) e+            q  = findAttr (qTag attr) e+     readAttr :: (Read a) => Element -> String -> a-    readAttr e attr = fromJust $ fmap read $ findAttr (unqual attr) e+    readAttr e attr = fromJust $ fmap read $ findAttr' attr e      readAttrM :: (Read a) => Element -> String -> Maybe a-    readAttrM e attr = fmap read $ findAttr (unqual attr) e+    readAttrM e attr = fmap read $ findAttr' attr e      -- | @readString e a d@ : @e@ element to read from; @a@ attribute to read; @d@ default value.     readString :: Element -> String -> String -> String-    readString e attr d = fromMaybe d $ findAttr (unqual attr) e+    readString e attr d = fromMaybe d $ findAttr' attr e      readStringM :: Element -> String -> Maybe String-    readStringM e attr = findAttr (unqual attr) e+    readStringM e attr = findAttr' attr e      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+                         (fmap read (findAttr' "horiz-adv-x" fontElement) )+    fontface | isJust uq = fromJust uq+             | isJust q  = fromJust q+             | otherwise = error "no fontface tag found in SVGFonts library" -- there is always a font-face node+      where uq = findElement (unqual "font-face") fontElement+            q  = findElement (qTag   "font-face") fontElement     bbox     = readString fontface "bbox" ""     parsedBBox :: Read n => [n]     parsedBBox = map read $ splitWhen isSpace bbox -    glyphElements = findChildren (unqual "glyph") fontElement-    kernings = findChildren (unqual "hkern") fontElement+    glyphElements = findChildren (unqual "glyph") fontElement +++                    findChildren (qTag "glyph") fontElement+    kernings      = findChildren (unqual "hkern") fontElement +++                    findChildren (qTag "hkern") fontElement      glyphs = map glyphsWithDefaults glyphElements      -- monospaced fonts sometimes don't have a "horiz-adv-x="-value , replace with "horiz-adv-x=" in <font>-    glyphsWithDefaults g = (charsFromFullName $ fromMaybe gname (findAttr (unqual "unicode") g), -- there is always a name or unicode-                             (-                               gname,-                               fromMaybe fontHadv (fmap read (findAttr (unqual "horiz-adv-x") g)),-                               fromMaybe "" (findAttr (unqual "d") g)-                             )-                           )-      where gname = fromMaybe "" (findAttr (unqual "glyph-name") g)+    glyphsWithDefaults g =+      (charsFromFullName $ fromMaybe gname (findAttr' "unicode" g), -- there is always a name or unicode+        (+          gname,+          fromMaybe fontHadv (fmap read (findAttr' "horiz-adv-x" g)),+          fromMaybe "" (findAttr' "d" g)+        )+      )+      where gname = fromMaybe "" (findAttr' "glyph-name" g) -    u1s         = map (fromMaybe "") $ map (findAttr (unqual "u1"))  kernings-    u2s         = map (fromMaybe "") $ map (findAttr (unqual "u2"))  kernings-    g1s         = map (fromMaybe "") $ map (findAttr (unqual "g1"))  kernings-    g2s         = map (fromMaybe "") $ map (findAttr (unqual "g2"))  kernings-    ks          = map (fromMaybe "") $ map (findAttr (unqual "k"))   kernings+    u1s         = map (fromMaybe "") $ map (findAttr' "u1")  kernings+    u2s         = map (fromMaybe "") $ map (findAttr' "u2")  kernings+    g1s         = map (fromMaybe "") $ map (findAttr' "g1")  kernings+    g2s         = map (fromMaybe "") $ map (findAttr' "g2")  kernings+    ks          = map (fromMaybe "") $ map (findAttr' "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+      let u1 = splitWhen (==',') $ fromMaybe "" $ findAttr' "u1" $ kerning+          u2 = splitWhen (==',') $ fromMaybe "" $ findAttr' "u2" $ kerning+          g1 = splitWhen (==',') $ fromMaybe "" $ findAttr' "g1" $ kerning+          g2 = splitWhen (==',') $ fromMaybe "" $ findAttr' "g2" $ kerning+          k  =                     fromMaybe "" $ findAttr' "k"  $ kerning       in (k, g1, g2, u1, u2)      transformChars chars = Map.fromList $ map ch $ multiSet $@@ -222,7 +241,9 @@ horizontalAdvance ch fontD     | isJust char = sel2 (fromJust char)     | otherwise   = fontDataHorizontalAdvance fontD-  where char = (Map.lookup ch (fontDataGlyphs fontD))+  where+    char = (Map.lookup ch (fontDataGlyphs fontD))+    sel2 (_, x, _) = x  -- | See <http://www.w3.org/TR/SVG/fonts.html#KernElements> --@@ -258,30 +279,32 @@         s sel ch = concat (maybeToList (Map.lookup ch (sel kern)))  -- > import Graphics.SVGFonts.ReadFont--- > textWH0 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "SPACES" lin INSIDE_WH KERN False 8 1 )+-- > linL <- loadDataFont "fonts/LinLibertine.svg"+-- > textWH0 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "SPACES" linL INSIDE_WH KERN False 8 1 ) -- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL--- > textWH1 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "are sometimes better." lin INSIDE_WH KERN False 8 1 )+-- > textWH1 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "are sometimes better." linL INSIDE_WH KERN False 8 1 ) -- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL--- > textWH2 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "But too many chars are not good." lin INSIDE_WH KERN False 8 1 )+-- > textWH2 = (rect 8 1) #+-- >             alignBL <> ((textSVG_ $ TextOpts "But too many chars are not good." linL INSIDE_WH KERN False 8 1 ) -- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL -- > textWH = textWH0 # alignBL === strutY 0.3 === textWH1 === strutY 0.3 === textWH2 # alignBL--- > textW0 = (rect 3 1) # alignBL <> ( (textSVG_ $ TextOpts "HEADLINE" lin INSIDE_W KERN False 3 1 )+-- > textW0 = (rect 3 1) # alignBL <> ( (textSVG_ $ TextOpts "HEADLINE" linL INSIDE_W KERN False 3 1 ) -- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd ) # alignBL--- > textW1 = (rect 10 1) # alignBL <> ( (textSVG_ $ TextOpts "HEADLINE" lin INSIDE_W KERN False 10 1 )+-- > textW1 = (rect 10 1) # alignBL <> ( (textSVG_ $ TextOpts "HEADLINE" linL INSIDE_W KERN False 10 1 ) -- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd ) # alignBL -- > textW = textW0 # alignBL ||| strutX 1 ||| textW1 # alignBL--- > textH0 = (rect 10 1) # alignBL <> ((textSVG_ $ TextOpts "Constant font size" lin INSIDE_H KERN False 10 1 )+-- > textH0 = (rect 10 1) # alignBL <> ((textSVG_ $ TextOpts "Constant font size" linL INSIDE_H KERN False 10 1 ) -- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL--- > textH1 = (rect 3 1) # alignBL <> ((textSVG_ $ TextOpts "Constant font size" lin INSIDE_H KERN False 3 1 )+-- > textH1 = (rect 3 1) # alignBL <> ((textSVG_ $ TextOpts "Constant font size" linL INSIDE_H KERN False 3 1 ) -- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL -- > textH = textH0 # alignBL === strutY 0.5 === textH1 # alignBL  -- > import Graphics.SVGFonts.ReadFont--- > textHADV = (textSVG_ $ TextOpts "AVENGERS" lin INSIDE_H HADV False 10 1 )+-- > textHADV = (textSVG_ $ TextOpts "AVENGERS" linL INSIDE_H HADV False 10 1 ) -- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd  -- > import Graphics.SVGFonts.ReadFont--- > textKern = (textSVG_ $ TextOpts "AVENGERS" lin INSIDE_H KERN False 10 1 )+-- > textKern = (textSVG_ $ TextOpts "AVENGERS" linL INSIDE_H KERN False 10 1 ) -- >              # fc blue # lc blue # bg lightgrey # fillRule EvenOdd  @@ -357,7 +380,8 @@ commandsToTrails ::RealFloat n => [PathCommand n] -> [Segment Closed V2 n] -> V2 n -> V2 n -> V2 n -> [Path V2 n] commandsToTrails [] _ _ _ _ = [] commandsToTrails (c:cs) segments l lastContr beginPoint -- l is the endpoint of the last segment-      | isNothing nextSegment = (translate beginPoint (pathFromTrail . wrapTrail  . closeLine $ lineFromSegments segments)) :+      | isNothing nextSegment =+        (translate beginPoint (pathFromTrail . wrapTrail  . closeLine $ lineFromSegments segments)) :                   ( commandsToTrails cs [] (l ^+^ offs) (contr c) (beginP c) ) -- one outline completed       | otherwise = commandsToTrails cs (segments ++ [fromJust nextSegment])                                            (l ^+^ offs) (contr c) (beginP c)   -- work on outline@@ -417,3 +441,5 @@ commands ch glyph = case Map.lookup ch glyph of     Just e -> pathFromString (sel3 e)     Nothing      -> Right []+  where+    sel3 (_, _, x) = x

@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -25,6 +27,8 @@ import Graphics.SVGFonts.ReadFont import Graphics.SVGFonts.CharReference (characterStrings) +import System.IO.Unsafe (unsafePerformIO)+ data TextOpts n = TextOpts   { textFont       :: PreparedFont n   , mode       :: Mode@@ -35,7 +39,7 @@   }  instance (Read n, RealFloat n) => Default (TextOpts n) where-    def = TextOpts lin INSIDE_H KERN False 1 1+    def = TextOpts (unsafePerformIO lin) INSIDE_H KERN False 1 1  -- | A short version of textSVG' with standard values. The Double value is the height. --@@ -62,8 +66,10 @@ textSVG' :: RealFloat n => TextOpts n -> String -> Path V2 n textSVG' topts text =   case mode topts of-    INSIDE_WH -> makeString (textHeight topts * sumh / maxY) (textHeight topts) (textWidth topts / (textHeight topts * sumh / maxY))-    INSIDE_W  -> makeString (textWidth topts) (textWidth topts * maxY / sumh)   1 -- the third character is used topts scale horizontal advances+    INSIDE_WH -> makeString (textHeight topts * sumh / maxY)+                            (textHeight topts) (textWidth topts / (textHeight topts * sumh / maxY))+    INSIDE_W  -> makeString (textWidth topts) -- the third character is used to scale horizontal advances+                            (textWidth topts * maxY / sumh) 1     INSIDE_H  -> makeString (textHeight topts * sumh / maxY) (textHeight topts) 1   where     makeString w h space = (scaleY (h/maxY) $ scaleX (w/sumh) $@@ -106,7 +112,8 @@             TextOpts n -> String -> QDiagram b V2 n Any textSVG_ topts text =   case mode topts of-    INSIDE_WH -> makeString (textHeight topts * sumh / maxY) (textHeight topts) ((textWidth topts) / (textHeight topts * sumh / maxY))+    INSIDE_WH -> makeString (textHeight topts * sumh / maxY) (textHeight topts)+                            ((textWidth topts) / (textHeight topts * sumh / maxY))     INSIDE_W  -> makeString (textWidth topts) (textWidth topts * maxY / sumh)   1     INSIDE_H  -> makeString (textHeight topts * sumh / maxY) (textHeight topts) 1   where@@ -115,7 +122,8 @@                             translateY (- bbox_ly fontD) $                             mconcat $                             zipWith translate (horPos space)-                            (map polygonChar (zip str (adjusted_hs space))) ) # stroke # withEnvelope ((rect (w*space) h) :: D V2 n)+                            (map polygonChar (zip str (adjusted_hs space))) )+                                    # stroke # withEnvelope ((rect (w*space) h) :: D V2 n)                           ) # alignBL # translateY (bbox_ly fontD*h/maxY)     (fontD,outl) = (textFont topts)     polygonChar (ch,a) = (fromMaybe mempty (Map.lookup ch outl)) <> (underlineChar a)