diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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) --------------------------- diff --git a/SVGFonts.cabal b/SVGFonts.cabal --- a/SVGFonts.cabal +++ b/SVGFonts.cabal @@ -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 (). 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: diff --git a/src/Graphics/SVGFonts.hs b/src/Graphics/SVGFonts.hs --- a/src/Graphics/SVGFonts.hs +++ b/src/Graphics/SVGFonts.hs @@ -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) diff --git a/src/Graphics/SVGFonts/Fonts.hs b/src/Graphics/SVGFonts/Fonts.hs --- a/src/Graphics/SVGFonts/Fonts.hs +++ b/src/Graphics/SVGFonts/Fonts.hs @@ -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. -- -- 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" 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 @@ -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 -tag found in SVG file using SVGFonts library." ++ + "Most likely wrong namespace in -tag. Please delete xmlns=...") + | otherwise = head $ catMaybes $ fontElements + fontElements = map (findElement (qTag "font")) xml ++ -- sometimes there is a namespace given with + +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 - 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 -- @@ -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 diff --git a/src/Graphics/SVGFonts/Text.hs b/src/Graphics/SVGFonts/Text.hs --- a/src/Graphics/SVGFonts/Text.hs +++ b/src/Graphics/SVGFonts/Text.hs @@ -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)