FontyFruity 0.5.3.2 → 0.5.3.3

raw patch · 14 files changed

+2966/−2942 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

- Graphics.Text.TrueType: [_e] :: CompositeScaling -> {-# UNPACK #-} !Int16

- Graphics.Text.TrueType: [_f] :: CompositeScaling -> {-# UNPACK #-} !Int16

- Graphics.Text.TrueType: CompositeScaling :: {-# UNPACK #-} !Int16 -> {-# UNPACK #-} !Int16 -> {-# UNPACK #-} !Int16 -> {-# UNPACK #-} !Int16 -> {-# UNPACK #-} !Int16 -> {-# UNPACK #-} !Int16 -> CompositeScaling

+ Graphics.Text.TrueType: CompositeScaling :: {-# UNPACK #-} !Int16 -> {-# UNPACK #-} !Int16 -> {-# UNPACK #-} !Int16 -> {-# UNPACK #-} !Int16 -> CompositeScaling

Files

FontyFruity.cabal +63/−63
changelog +70/−66
src/Graphics/Text/TrueType.hs +514/−496
src/Graphics/Text/TrueType/Bytecode.hs +448/−448
src/Graphics/Text/TrueType/CharacterMap.hs +385/−385
src/Graphics/Text/TrueType/FontFolders.hs +241/−241
src/Graphics/Text/TrueType/Glyph.hs +322/−331
src/Graphics/Text/TrueType/Header.hs +143/−143
src/Graphics/Text/TrueType/HorizontalInfo.hs +120/−120
src/Graphics/Text/TrueType/LanguageIds.hs +342/−331
src/Graphics/Text/TrueType/MaxpTable.hs +59/−59
src/Graphics/Text/TrueType/Name.hs +122/−122
src/Graphics/Text/TrueType/OffsetTable.hs +89/−89
src/Graphics/Text/TrueType/Types.hs +48/−48

FontyFruity.cabal view

@@ -1,63 +1,63 @@--- Initial FontyFruity.cabal generated by cabal init.  For further --- documentation, see http://haskell.org/cabal/users-guide/--name:                FontyFruity-version:             0.5.3.2-synopsis:            A true type file format loader-description:         -    A haskell Truetype file parser.-    .-    You can load a font file and extract some curves to be-    drawed with a library like Rasterific .-license:             BSD3-license-file:        LICENSE-author:              Vincent Berthoux-maintainer:          vincent.berthoux@gmail.com--- copyright:           -category:            Graphics, Text, Font-build-type:          Simple--- extra-source-files:  -cabal-version:       >=1.10--extra-source-files: changelog--Source-Repository head-    Type:      git-    Location:  https://github.com/Twinside/FontyFruity.git--Source-Repository this-    Type:      git-    Location:  https://github.com/Twinside/FontyFruity.git-    Tag:       v0.5.3.2--library-  exposed-modules: Graphics.Text.TrueType-                 , Graphics.Text.TrueType.Internal-  other-modules: Graphics.Text.TrueType.Bytecode    -               , Graphics.Text.TrueType.MaxpTable-               , Graphics.Text.TrueType.Header-               , Graphics.Text.TrueType.Glyph-               , Graphics.Text.TrueType.Types-               , Graphics.Text.TrueType.OffsetTable-               , Graphics.Text.TrueType.CharacterMap-               , Graphics.Text.TrueType.LanguageIds-               , Graphics.Text.TrueType.HorizontalInfo-               , Graphics.Text.TrueType.Name-               , Graphics.Text.TrueType.FontFolders-               , Graphics.Text.TrueType.FontType--  ghc-options: -Wall -O2-  ghc-prof-options: -Wall-  hs-source-dirs:      src-  default-language:    Haskell2010-  build-depends: base       >= 4.5 && < 5-               , binary     >= 0.5-               , bytestring >= 0.10-               , containers >= 0.5 && < 0.6-               , vector     >= 0.9-               , directory-               , text-               , filepath-               , deepseq    >= 1.2-               , xml        >= 1.3-+-- Initial FontyFruity.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                FontyFruity
+version:             0.5.3.3
+synopsis:            A true type file format loader
+description:         
+    A haskell Truetype file parser.
+    .
+    You can load a font file and extract some curves to be
+    drawed with a library like Rasterific .
+license:             BSD3
+license-file:        LICENSE
+author:              Vincent Berthoux
+maintainer:          vincent.berthoux@gmail.com
+-- copyright:           
+category:            Graphics, Text, Font
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+extra-source-files: changelog
+
+Source-Repository head
+    Type:      git
+    Location:  https://github.com/Twinside/FontyFruity.git
+
+Source-Repository this
+    Type:      git
+    Location:  https://github.com/Twinside/FontyFruity.git
+    Tag:       v0.5.3.3
+
+library
+  exposed-modules: Graphics.Text.TrueType
+                 , Graphics.Text.TrueType.Internal
+  other-modules: Graphics.Text.TrueType.Bytecode    
+               , Graphics.Text.TrueType.MaxpTable
+               , Graphics.Text.TrueType.Header
+               , Graphics.Text.TrueType.Glyph
+               , Graphics.Text.TrueType.Types
+               , Graphics.Text.TrueType.OffsetTable
+               , Graphics.Text.TrueType.CharacterMap
+               , Graphics.Text.TrueType.LanguageIds
+               , Graphics.Text.TrueType.HorizontalInfo
+               , Graphics.Text.TrueType.Name
+               , Graphics.Text.TrueType.FontFolders
+               , Graphics.Text.TrueType.FontType
+
+  ghc-options: -Wall -O2
+  ghc-prof-options: -Wall
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  build-depends: base       >= 4.5 && < 5
+               , binary     >= 0.5
+               , bytestring >= 0.10
+               , containers >= 0.5 && < 0.6
+               , vector     >= 0.9
+               , directory
+               , text
+               , filepath
+               , deepseq    >= 1.2
+               , xml        >= 1.3
+

changelog view

@@ -1,66 +1,70 @@--*-change-log-*---v0.5.3.2 May 2016- * Fix: Bumping base bounds--v0.5.3(.1) February 2016- * Fix: bug when trying to scan a directory- * Addition: exposing descriptorOf function- * Enhancement: Made FontDescriptor strictier.--v0.5.2 August 2015- * Fix: GHC 7.4 compilation--v0.5.1.1 April 2015- * Fix: compilation on older compilers--v0.5.1 April 2015- * Fix: Fixing the bounding box returned by stringBoundingBox - * Fix: All warning of GHC 7.10 final--v0.5 January 2015- * BREAKING CHANGE: the point size is now Float!-- ---- Non breaking change:- * Adding: lower level access to the structure, without-   guaranteed stability.- * Adding: an helper function to retrieve the distance from-   the top of the string bounding box to the baseline.--v0.4.1 January 2015- * Fixing: Warnings under GHC 7.1O--v0.4- * Adding: function to get back unplaced glyph.- * Adding: Binary instance for Font cache.- * Fixing: font cache.--v0.3 June 2014- * Adding: a font finding function- * Adding: a font cache type to speed-up frequent font-   finding.--v0.2.1 April 2014- * Fixing: some character map loading problem (again)- * Fixing: font loading with out of order tables--v0.2 March 2014- * Fixing: character map loading when identical table-   offset are used.- * Adding: bounding box extraction for test snippet.--v0.1.0.4 February 2014- * Fixing: hackage's haddock generation--v0.1.0.3 February 2014- * Dropping base upper bound.--v0.1.0.2 February 2014- * Fixing: compilation with old version of binary.--v0.1.0.1 February 2014- * Fixing: some missing information in the cabal file.--v0.1 February 2014- * Initial version.-+-*-change-log-*-
+
+v0.5.3.3 June 2017
+ * Fix: Composite glyph positionning (patch from hsyl20)
+ * Fix: glyph lookup (patch from hsyl20)
+
+v0.5.3.2 May 2016
+ * Fix: Bumping base bounds
+
+v0.5.3(.1) February 2016
+ * Fix: bug when trying to scan a directory
+ * Addition: exposing descriptorOf function
+ * Enhancement: Made FontDescriptor strictier.
+
+v0.5.2 August 2015
+ * Fix: GHC 7.4 compilation
+
+v0.5.1.1 April 2015
+ * Fix: compilation on older compilers
+
+v0.5.1 April 2015
+ * Fix: Fixing the bounding box returned by stringBoundingBox 
+ * Fix: All warning of GHC 7.10 final
+
+v0.5 January 2015
+ * BREAKING CHANGE: the point size is now Float!
+
+ ---- Non breaking change:
+ * Adding: lower level access to the structure, without
+   guaranteed stability.
+ * Adding: an helper function to retrieve the distance from
+   the top of the string bounding box to the baseline.
+
+v0.4.1 January 2015
+ * Fixing: Warnings under GHC 7.1O
+
+v0.4
+ * Adding: function to get back unplaced glyph.
+ * Adding: Binary instance for Font cache.
+ * Fixing: font cache.
+
+v0.3 June 2014
+ * Adding: a font finding function
+ * Adding: a font cache type to speed-up frequent font
+   finding.
+
+v0.2.1 April 2014
+ * Fixing: some character map loading problem (again)
+ * Fixing: font loading with out of order tables
+
+v0.2 March 2014
+ * Fixing: character map loading when identical table
+   offset are used.
+ * Adding: bounding box extraction for test snippet.
+
+v0.1.0.4 February 2014
+ * Fixing: hackage's haddock generation
+
+v0.1.0.3 February 2014
+ * Dropping base upper bound.
+
+v0.1.0.2 February 2014
+ * Fixing: compilation with old version of binary.
+
+v0.1.0.1 February 2014
+ * Fixing: some missing information in the cabal file.
+
+v0.1 February 2014
+ * Initial version.
+

src/Graphics/Text/TrueType.hs view

@@ -1,496 +1,514 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | Module in charge of loading fonts.-module Graphics.Text.TrueType-    ( -- * Functions-      decodeFont-    , loadFontFile-    , getStringCurveAtPoint-    , unitsPerEm-    , isPlaceholder-    , getCharacterGlyphsAndMetrics-    , getGlyphForStrings-    , stringBoundingBox-    , findFontOfFamily-    , pointInPixelAtDpi-    , pixelSizeInPointAtDpi--      -- * Font cache-    , FontCache-    , FontDescriptor( .. )-    , emptyFontCache-    , findFontInCache-    , buildCache-    , enumerateFonts-    , descriptorOf--      -- * Types-    , Font-    , FontStyle( .. )-    , RawGlyph( .. )-    , Dpi-    , PointSize( .. )-    , CompositeScaling( .. )-    , BoundingBox( .. )-    ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( mempty )-import Control.Applicative((<$>))-#endif--import Control.Monad( foldM, forM )-import Data.Function( on )-import Data.Int ( Int16 )-import Data.List( sortBy, mapAccumL, foldl' )-import Data.Word( Word16 )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( Get-                      , bytesRead-                      , getWord16be-                      , getWord32be-                      , getLazyByteString-                      , skip-                      )--#if MIN_VERSION_binary(0,6,4)-import qualified Data.Binary.Get as G-import Control.DeepSeq( NFData )-#else-import qualified Data.Binary.Get as G-import qualified Control.Exception as E--- I feel so dirty. :(-import System.IO.Unsafe( unsafePerformIO )-import Control.DeepSeq( NFData, ($!!) )-#endif--import qualified Data.Map as M-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy as LB-import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as VU--{-import Graphics.Text.TrueType.Types-}-import Graphics.Text.TrueType.MaxpTable-import Graphics.Text.TrueType.Glyph-import Graphics.Text.TrueType.Header-import Graphics.Text.TrueType.OffsetTable-import Graphics.Text.TrueType.CharacterMap-import Graphics.Text.TrueType.HorizontalInfo-import Graphics.Text.TrueType.Name()-import Graphics.Text.TrueType.FontType-import Graphics.Text.TrueType.FontFolders--{-import Debug.Trace-}---- | Load a font file, the file path must be pointing--- to the true type file (.ttf)-loadFontFile :: FilePath -> IO (Either String Font)-loadFontFile filepath = decodeFont <$> LB.readFile filepath--getOrFail :: NFData a => Get a -> LB.ByteString -> Either String a-getOrFail getter str =-#if MIN_VERSION_binary(0,6,4)-  case G.runGetOrFail getter str of-    Left err -> Left $ show err-    Right (_, _, value) -> Right value-#else-  unsafePerformIO $ E.evaluate (let v = G.runGet getter str in-                                return $!! v)-    `E.catch` catcher-      where catcher :: E.SomeException -> IO (Either String a)-            catcher e = return . Left $ show e-#endif---- | Decode a in-memory true type file.-decodeFont :: LB.ByteString -> Either String Font-decodeFont = getOrFail getFont--decodeWithDefault :: forall a . (NFData a, Binary a)-                  => a -> LB.ByteString -> a-decodeWithDefault defaultValue str =-    case getOrFail get str of-      Left _ -> defaultValue-      Right v -> v--gotoOffset :: TableDirectoryEntry -> Get ()-gotoOffset entry = do-    readed <- bytesRead-    let toDrop = fromIntegral (_tdeOffset entry) - readed-    if toDrop < 0 then fail "Weirdo weird"-    else skip $ fromIntegral toDrop--getLoca :: Font -> Get Font-getLoca font@(Font { _fontMaxp = Just maxp, _fontHeader = Just hdr })-  | _fHdrIndexToLocFormat hdr == 0 = do-      v <- VU.replicateM glyphCount-            ((* 2) . fromIntegral <$> getWord16be)-      return font { _fontLoca = Just v }-  | otherwise = do-      v <- VU.replicateM glyphCount getWord32be-      return font { _fontLoca = Just v }-  where glyphCount = fromIntegral $ _maxpnumGlyphs maxp-getLoca font = return font--getGlyph :: Font -> LB.ByteString -> Get Font-getGlyph font@(Font { _fontLoca = Just locations }) str =--  return font { _fontGlyph = Just . V.map decoder $ VU.convert locationInterval }-      where decoder (xStart, xEnd)-                | xEnd <= xStart = emptyGlyph-                | otherwise =-                    decodeWithDefault emptyGlyph $ chop xStart xEnd-            chop start _ = LB.drop (fromIntegral start) str-            locationsAll = locations `VU.snoc` fromIntegral (LB.length str)-            locationInterval = VU.zip locations $ VU.tail locationsAll-getGlyph font _ = return font--getHmtx :: Font -> Get Font-getHmtx font@Font { _fontMaxp = Just maxp,-                    _fontHorizontalHeader = Just hdr } = do-  let metricCount = _hheaLongHorMetricCount hdr-      glyphCount = fromIntegral $ _maxpnumGlyphs maxp-  table <- getHorizontalMetrics (fromIntegral metricCount) glyphCount-  return font { _fontHorizontalMetrics = Just table }-getHmtx font = return font--fetchTables :: [String] -> OffsetTable -> Get Font-fetchTables tableList offsetTable = do-    let sortedTables =-            sortBy (compare `on` _tdeOffset) . V.toList $ _otEntries offsetTable-    tableData <--      forM sortedTables $ \entry -> do-          gotoOffset entry-          (B.unpack $ _tdeTag entry,) <$> getLazyByteString (fromIntegral $ _tdeLength entry)--    foldM (fetch tableData) (emptyFont offsetTable) tableList--  where-    getFetch tables name getter =-      case [str | (n, str) <- tables, n == name] of-        [] -> fail $ "Table not found " ++ name-        (s:_) ->-            case getOrFail getter s of-               Left err -> fail err-               Right v -> return v--    fetch tables font "head" = do-      table <- getFetch tables "head" get-      return $ font { _fontHeader = Just table }--    fetch tables font "maxp" = do-      table <- getFetch tables "maxp" get-      return $ font { _fontMaxp = Just table }--    fetch tables font "cmap" = do-      table <- getFetch tables "cmap" get-      return $ font { _fontMap = Just table }--    fetch tables font "name" = do-      table <- getFetch tables "name" get-      return $ font { _fontNames = Just table }--    fetch tables font "hhea" = do-      table <- getFetch tables "hhea" get-      return $ font { _fontHorizontalHeader = Just table }--    fetch tables font "glyf" =-      case [getGlyph font s | ("glyf", s) <- tables] of-        [] -> return font-        (g:_) -> g--    fetch tables font "loca" =-      getFetch tables "loca" (getLoca font)--    fetch tables font "hmtx" =-      getFetch tables "hmtx" (getHmtx font)--    fetch _ font _ = return font--getFont :: Get Font-getFont = get >>= fetchTables allTables-  where-    allTables = ["head", "maxp", "cmap", "name", "hhea",  "loca", "glyf", "hmtx"]--getFontNameAndStyle :: Get Font-getFontNameAndStyle =-    (filterTable isNecessaryForName <$> get) >>= fetchTables ["head", "name"]-  where-    isNecessaryForName v = v == "name" || v == "head"---- | This function will search in the system for truetype--- files and index them in a cache for further fast search.-buildCache :: IO FontCache-buildCache = buildFontCache loader-  where-    loader n =-        toMayb . getOrFail getFontNameAndStyle <$> LB.readFile n-    toMayb (Left _) = Nothing-    toMayb (Right v) = Just v---- | Try to find a font with the given properties in the--- font cache.-findFontInCache :: FontCache -> FontDescriptor -> Maybe FilePath-findFontInCache (FontCache cache) descr = M.lookup descr cache---- | This function will scan the system's font folder to--- find a font with the desired properties. Favor using--- a FontCache to speed up the lookup process.-findFontOfFamily :: String -> FontStyle -> IO (Maybe FilePath)-findFontOfFamily = findFont loader-  where-    loader n =-        toMayb . getOrFail getFontNameAndStyle <$> LB.readFile n-    toMayb (Left _) = Nothing-    toMayb (Right v) = Just v---- | Express device resolution in dot per inch.-type Dpi = Int---- | Font size expressed in points.--- You must convert size expressed in pixels to point using--- the DPI information.--- See pixelSizeInPointAtDpi-newtype PointSize = PointSize { getPointSize :: Float }-    deriving (Eq, Show)--toPixelCoord :: (Integral a) => Font -> PointSize -> Dpi -> a -> Float-toPixelCoord font pointSize dpi v =-    (fromIntegral v * getPointSize pointSize * fromIntegral dpi) /-    (72 * emSize)-  where-    emSize = fromIntegral $ unitsPerEm font--toFCoord :: Integral a => Font -> PointSize -> Dpi -> Float -> a-toFCoord font size dpi v = floor $ v * emSize / pixelSize-  where-    emSize = fromIntegral $ unitsPerEm font-    pixelSize = size `pointInPixelAtDpi` dpi---pointInPixelAtDpi :: PointSize -> Dpi -> Float-pointInPixelAtDpi size dpi =-    (getPointSize size * fromIntegral dpi) / 72--pixelSizeInPointAtDpi :: Float -> Dpi -> PointSize-pixelSizeInPointAtDpi pixelSize dpi =-    PointSize $ (pixelSize / fromIntegral dpi) * 72--glyphOfStrings :: Font -> String -> [(Glyph, HorizontalMetric)]-glyphOfStrings Font { _fontMap = Just mapping-                    , _fontGlyph = Just glyphes-                    , _fontHorizontalMetrics = Just hmtx } str =-    fetcher . findCharGlyph mapping 0 <$> str-  where-    fetcher ix = (glyphes V.! ix, _glyphMetrics hmtx V.! ix)-glyphOfStrings _ _ = []---- | Return the number of pixels relative to the point size.-unitsPerEm :: Font -> Word16-unitsPerEm Font { _fontHeader = Just hdr } =-    fromIntegral $ _fUnitsPerEm hdr-unitsPerEm  _ = 1---- | String bounding box. with value for--- min/max.-data BoundingBox = BoundingBox-  { _xMin :: {-# UNPACK #-} !Float-  , _yMin :: {-# UNPACK #-} !Float-  , _xMax :: {-# UNPACK #-} !Float-  , _yMax :: {-# UNPACK #-} !Float-    -- | Should be 0 most of the times.-  , _baselineHeight :: {-# UNPACK #-} !Float-  }-  deriving (Eq)---- | Compute the bounding box of a string displayed with a font at--- a given size. The resulting coordinate represent the width and the--- height in pixels.-stringBoundingBox :: Font -> Dpi -> PointSize -> String -> BoundingBox-stringBoundingBox font dpi size str =-    BoundingBox xMini yMini width yMaxi 0-  where-    glyphs = glyphOfStrings font str-    xMini = case glyphs of-        [] -> 0-        (glyph, _):_ -> toPixel . _glfXMin $ _glyphHeader glyph--    (width, yMini, yMaxi) =-        foldl' go (0, 0, 0) glyphs--    toPixel :: Integral a => a -> Float-    toPixel = toPixelCoord font size dpi--    go (xf, yMin, yMax) (glyph, metric) = (width', yMin', yMax')-      where-        advance = _hmtxAdvanceWidth metric-        width' = xf + toPixel advance-        yMin' = min yMin. toPixel . _glfYMin $ _glyphHeader glyph-        yMax' = max yMax. toPixel . _glfYMax $ _glyphHeader glyph----- | Extract a list of outlines for every char in the string.--- The given curves are in an image like coordinate system,--- with the origin point in the upper left corner.-getStringCurveAtPoint :: Dpi            -- ^ Dot per inch of the output.-                      -> (Float, Float) -- ^ Initial position of the baseline.-                      -> [(Font, PointSize, String)] -- ^ Text to draw-                      -> [[VU.Vector (Float, Float)]] -- ^ List of contours for each char-getStringCurveAtPoint dpi initPos lst = snd $ mapAccumL go initPos glyphes where-  glyphes = concat [(font, size,)-                         <$> glyphOfStrings font str | (font, size, str) <- lst]--  toPixel (font, pointSize, _) = toPixelCoord font pointSize dpi-  toCoord (font, pointSize, _) = toFCoord font pointSize dpi--  maximumSize = maximum [ toPixel p . _glfYMax $ _glyphHeader glyph-                                | p@(_, _, (glyph, _)) <- glyphes ]--  go (xf, yf) p@(font, pointSize, (glyph, metric)) = ((toPixel p $ xi + advance, yf), curves)-    where-      (xi, yi) = (toCoord p xf, toCoord p yf)-      bearing = fromIntegral $ _hmtxLeftSideBearing metric-      advance = fromIntegral $ _hmtxAdvanceWidth metric-      curves =-          getGlyphIndexCurvesAtPointSizeAndPos font dpi (toCoord p maximumSize)-            (pointSize, glyph) (xi + bearing, yi)---- | This function return the list of all contour for all char with the given--- font in a string. All glyph are at the same position, they are not placed--- like with `getStringCurveAtPoint`. It is a function helpful to extract--- the glyph geometry for further external manipulation.-getGlyphForStrings :: Dpi -> [(Font, PointSize, String)]-                   -> [[VU.Vector (Float, Float)]]-getGlyphForStrings dpi lst =  go <$> glyphes where-  glyphes = concat-    [(font, size,) <$> glyphOfStrings font str | (font, size, str) <- lst]--  toCoord (font, pointSize, _) = toFCoord font pointSize dpi--  maximumSize :: Float-  maximumSize =-     maximum [ toPixelCoord font pointSize dpi . _glfYMax $ _glyphHeader glyph-                   | (font, pointSize, (glyph, _)) <- glyphes ]--  go p@(font, pointSize, (glyph, _metric)) =-    getGlyphIndexCurvesAtPointSizeAndPos-        font dpi (toCoord p maximumSize) (pointSize, glyph) (0, 0)--getGlyphIndexCurvesAtPointSizeAndPos :: Font -> Dpi -> Int -> (PointSize, Glyph)-                                     -> (Int, Int)-                                     -> [VU.Vector (Float, Float)]-getGlyphIndexCurvesAtPointSizeAndPos Font { _fontHeader = Nothing } _ _ _ _ = []-getGlyphIndexCurvesAtPointSizeAndPos Font { _fontGlyph = Nothing } _ _ _ _ = []-getGlyphIndexCurvesAtPointSizeAndPos-    Font { _fontHeader = Just hdr, _fontGlyph = Just allGlyphs }-        dpi _maximumSize (pointSize, topGlyph) (baseX, baseY) = glyphReverse <$> glyphExtract topGlyph-  where-    go index | index >= V.length allGlyphs = []-             | otherwise = glyphExtract $ allGlyphs V.! index--    pixelSize = pointSize `pointInPixelAtDpi` dpi-    emSize = fromIntegral $ _fUnitsPerEm hdr--    baseYF = toPixelCoordinate (0 :: Int) baseY--    glyphReverse = VU.map (\(x,y) -> (x, baseYF - y))--    toPixelCoordinate shift coord =-        (fromIntegral (shift + fromIntegral coord) * pixelSize) / emSize--    composeGlyph composition = VU.map updateCoords <$> subCurves-      where-        subCurves = go . fromIntegral $ _glyphCompositeIndex composition-        toFloat v = fromIntegral v / (0x4000 :: Float)-        CompositeScaling ai bi ci di ei fi = _glyphCompositionScale composition--        scaler v1 v2-            | fromIntegral (abs (abs ai - abs ci)) <= (33 / 65536 :: Float) = 2 * vf-            | otherwise = vf-          where-           vf = toFloat $ max (abs v1) (abs v2)--        m = scaler ai bi-        n = scaler ci di--        am = toFloat ai / m-        cm = toFloat ci / m-        bn = toFloat ci / n-        dn = toFloat di / n-        e = fromIntegral ei-        f = fromIntegral fi--        updateCoords (x,y) =-            (m * (am * x + cm *y + e), n * (bn * x + dn * y + f))--    glyphExtract Glyph { _glyphContent = GlyphEmpty } = []-    glyphExtract Glyph { _glyphContent = GlyphComposite compositions _ } =-        concatMap composeGlyph $ V.toList compositions-    glyphExtract Glyph { _glyphContent = GlyphSimple countour } =-        [ VU.map mapper c | c <- extractFlatOutline countour]-      where-        mapper (x,y) =-          (toPixelCoordinate baseX x, toPixelCoordinate (0 :: Int) y)---- | True if the character is not present in the font, therefore it--- will appear as a placeholder in renderings.-isPlaceholder :: Font -> Char -> Bool-isPlaceholder Font { _fontMap = Just fontMap } character =-    findCharGlyph fontMap 0 character == 0-isPlaceholder Font { _fontMap = Nothing } _ = True---- | Retrive the glyph contours and associated transformations.--- The coordinate system is assumed to be the TTF one (y upward).--- No transformation is performed.-getCharacterGlyphsAndMetrics :: Font-                             -> Char-                             -> (Float, V.Vector RawGlyph) -- ^ Advance and glyph information.-getCharacterGlyphsAndMetrics-    Font { _fontMap = Just mapping-         , _fontGlyph = Just allGlyphs-         , _fontHorizontalMetrics = Just hmtx }-        character =-    (advance, getCharacterGlyphs allGlyphs allMetrics glyphIndex)-  where-    glyphIndex = findCharGlyph mapping 0 character-    allMetrics = _glyphMetrics hmtx-    metrics = allMetrics V.! glyphIndex-    advance = fromIntegral (_hmtxAdvanceWidth metrics)-getCharacterGlyphsAndMetrics _ _ = (0, mempty)---- | This type represent unscaled glyph information, everything--- is still in its raw form.-data RawGlyph = RawGlyph-    { -- | List of transformations to apply to the contour in order-      -- to get their correct placement.-      _rawGlyphCompositionScale :: ![CompositeScaling]--      -- | Glyph index in the current font.-    , _rawGlyphIndex            :: !Int--      -- | Real Geometry of glyph, each vector contain one-      -- contour.-    , _rawGlyphContour          :: ![VU.Vector (Int16, Int16)]-    }--prependScale :: CompositeScaling -> RawGlyph -> RawGlyph-prependScale scale rGlyph =-    rGlyph { _rawGlyphCompositionScale = scale : _rawGlyphCompositionScale rGlyph }--getCharacterGlyphs :: V.Vector Glyph -> V.Vector HorizontalMetric -> Int-                   -> V.Vector RawGlyph-getCharacterGlyphs allGlyphs allMetrics glyphIndex =-    case _glyphContent (allGlyphs V.! glyphIndex) of-      GlyphEmpty -> mempty-      GlyphComposite compositions _ -> V.concatMap expandComposition compositions-      GlyphSimple countour ->-          V.singleton . RawGlyph mempty glyphIndex $ extractFlatOutline countour-  where-    recurse = getCharacterGlyphs allGlyphs allMetrics --    expandComposition GlyphComposition { _glyphCompositeIndex = index-                                       , _glyphCompositionScale = scale } =-      V.map (prependScale scale) . recurse $ fromIntegral index-+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- | Module in charge of loading fonts.
+module Graphics.Text.TrueType
+    ( -- * Functions
+      decodeFont
+    , loadFontFile
+    , getStringCurveAtPoint
+    , unitsPerEm
+    , isPlaceholder
+    , getCharacterGlyphsAndMetrics
+    , getGlyphForStrings
+    , stringBoundingBox
+    , findFontOfFamily
+    , pointInPixelAtDpi
+    , pixelSizeInPointAtDpi
+
+      -- * Font cache
+    , FontCache
+    , FontDescriptor( .. )
+    , emptyFontCache
+    , findFontInCache
+    , buildCache
+    , enumerateFonts
+    , descriptorOf
+
+      -- * Types
+    , Font
+    , FontStyle( .. )
+    , RawGlyph( .. )
+    , Dpi
+    , PointSize( .. )
+    , CompositeScaling( .. )
+    , BoundingBox( .. )
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid( mempty )
+import Control.Applicative((<$>))
+#endif
+
+import Control.Monad( foldM, forM )
+import Data.Function( on )
+import Data.Int ( Int16 )
+import Data.List( sortBy, mapAccumL, foldl' )
+import Data.Word( Word16 )
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( Get
+                      , bytesRead
+                      , getWord16be
+                      , getWord32be
+                      , getLazyByteString
+                      , skip
+                      )
+
+#if MIN_VERSION_binary(0,6,4)
+import qualified Data.Binary.Get as G
+import Control.DeepSeq( NFData )
+#else
+import qualified Data.Binary.Get as G
+import qualified Control.Exception as E
+-- I feel so dirty. :(
+import System.IO.Unsafe( unsafePerformIO )
+import Control.DeepSeq( NFData, ($!!) )
+#endif
+
+import qualified Data.Map as M
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.Vector as V
+import qualified Data.Vector.Unboxed as VU
+
+{-import Graphics.Text.TrueType.Types-}
+import Graphics.Text.TrueType.MaxpTable
+import Graphics.Text.TrueType.Glyph
+import Graphics.Text.TrueType.Header
+import Graphics.Text.TrueType.OffsetTable
+import Graphics.Text.TrueType.CharacterMap
+import Graphics.Text.TrueType.HorizontalInfo
+import Graphics.Text.TrueType.Name()
+import Graphics.Text.TrueType.FontType
+import Graphics.Text.TrueType.FontFolders
+
+{-import Debug.Trace-}
+
+-- | Load a font file, the file path must be pointing
+-- to the true type file (.ttf)
+loadFontFile :: FilePath -> IO (Either String Font)
+loadFontFile filepath = decodeFont <$> LB.readFile filepath
+
+getOrFail :: NFData a => Get a -> LB.ByteString -> Either String a
+getOrFail getter str =
+#if MIN_VERSION_binary(0,6,4)
+  case G.runGetOrFail getter str of
+    Left err -> Left $ show err
+    Right (_, _, value) -> Right value
+#else
+  unsafePerformIO $ E.evaluate (let v = G.runGet getter str in
+                                return $!! v)
+    `E.catch` catcher
+      where catcher :: E.SomeException -> IO (Either String a)
+            catcher e = return . Left $ show e
+#endif
+
+-- | Decode a in-memory true type file.
+decodeFont :: LB.ByteString -> Either String Font
+decodeFont = getOrFail getFont
+
+decodeWithDefault :: forall a . (NFData a, Binary a)
+                  => a -> LB.ByteString -> a
+decodeWithDefault defaultValue str =
+    case getOrFail get str of
+      Left _ -> defaultValue
+      Right v -> v
+
+gotoOffset :: TableDirectoryEntry -> Get ()
+gotoOffset entry = do
+    readed <- bytesRead
+    let toDrop = fromIntegral (_tdeOffset entry) - readed
+    if toDrop < 0 then fail "Weirdo weird"
+    else skip $ fromIntegral toDrop
+
+getLoca :: Font -> Get Font
+getLoca font@(Font { _fontMaxp = Just maxp, _fontHeader = Just hdr })
+  | _fHdrIndexToLocFormat hdr == 0 = do
+      v <- VU.replicateM glyphCount
+            ((* 2) . fromIntegral <$> getWord16be)
+      return font { _fontLoca = Just v }
+  | otherwise = do
+      v <- VU.replicateM glyphCount getWord32be
+      return font { _fontLoca = Just v }
+  where glyphCount = fromIntegral $ _maxpnumGlyphs maxp
+getLoca font = return font
+
+getGlyph :: Font -> LB.ByteString -> Get Font
+getGlyph font@(Font { _fontLoca = Just locations }) str =
+
+  return font { _fontGlyph = Just . V.map decoder $ VU.convert locationInterval }
+      where decoder (xStart, xEnd)
+                | xEnd <= xStart = emptyGlyph
+                | otherwise =
+                    decodeWithDefault emptyGlyph $ chop xStart xEnd
+            chop start _ = LB.drop (fromIntegral start) str
+            locationsAll = locations `VU.snoc` fromIntegral (LB.length str)
+            locationInterval = VU.zip locations $ VU.tail locationsAll
+getGlyph font _ = return font
+
+getHmtx :: Font -> Get Font
+getHmtx font@Font { _fontMaxp = Just maxp,
+                    _fontHorizontalHeader = Just hdr } = do
+  let metricCount = _hheaLongHorMetricCount hdr
+      glyphCount = fromIntegral $ _maxpnumGlyphs maxp
+  table <- getHorizontalMetrics (fromIntegral metricCount) glyphCount
+  return font { _fontHorizontalMetrics = Just table }
+getHmtx font = return font
+
+fetchTables :: [String] -> OffsetTable -> Get Font
+fetchTables tableList offsetTable = do
+    let sortedTables =
+            sortBy (compare `on` _tdeOffset) . V.toList $ _otEntries offsetTable
+    tableData <-
+      forM sortedTables $ \entry -> do
+          gotoOffset entry
+          (B.unpack $ _tdeTag entry,) <$> getLazyByteString (fromIntegral $ _tdeLength entry)
+
+    foldM (fetch tableData) (emptyFont offsetTable) tableList
+
+  where
+    getFetch tables name getter =
+      case [str | (n, str) <- tables, n == name] of
+        [] -> fail $ "Table not found " ++ name
+        (s:_) ->
+            case getOrFail getter s of
+               Left err -> fail err
+               Right v -> return v
+
+    fetch tables font "head" = do
+      table <- getFetch tables "head" get
+      return $ font { _fontHeader = Just table }
+
+    fetch tables font "maxp" = do
+      table <- getFetch tables "maxp" get
+      return $ font { _fontMaxp = Just table }
+
+    fetch tables font "cmap" = do
+      table <- getFetch tables "cmap" get
+      return $ font { _fontMap = Just table }
+
+    fetch tables font "name" = do
+      table <- getFetch tables "name" get
+      return $ font { _fontNames = Just table }
+
+    fetch tables font "hhea" = do
+      table <- getFetch tables "hhea" get
+      return $ font { _fontHorizontalHeader = Just table }
+
+    fetch tables font "glyf" =
+      case [getGlyph font s | ("glyf", s) <- tables] of
+        [] -> return font
+        (g:_) -> g
+
+    fetch tables font "loca" =
+      getFetch tables "loca" (getLoca font)
+
+    fetch tables font "hmtx" =
+      getFetch tables "hmtx" (getHmtx font)
+
+    fetch _ font _ = return font
+
+getFont :: Get Font
+getFont = get >>= fetchTables allTables
+  where
+    allTables = ["head", "maxp", "cmap", "name", "hhea",  "loca", "glyf", "hmtx"]
+
+getFontNameAndStyle :: Get Font
+getFontNameAndStyle =
+    (filterTable isNecessaryForName <$> get) >>= fetchTables ["head", "name"]
+  where
+    isNecessaryForName v = v == "name" || v == "head"
+
+-- | This function will search in the system for truetype
+-- files and index them in a cache for further fast search.
+buildCache :: IO FontCache
+buildCache = buildFontCache loader
+  where
+    loader n =
+        toMayb . getOrFail getFontNameAndStyle <$> LB.readFile n
+    toMayb (Left _) = Nothing
+    toMayb (Right v) = Just v
+
+-- | Try to find a font with the given properties in the
+-- font cache.
+findFontInCache :: FontCache -> FontDescriptor -> Maybe FilePath
+findFontInCache (FontCache cache) descr = M.lookup descr cache
+
+-- | This function will scan the system's font folder to
+-- find a font with the desired properties. Favor using
+-- a FontCache to speed up the lookup process.
+findFontOfFamily :: String -> FontStyle -> IO (Maybe FilePath)
+findFontOfFamily = findFont loader
+  where
+    loader n =
+        toMayb . getOrFail getFontNameAndStyle <$> LB.readFile n
+    toMayb (Left _) = Nothing
+    toMayb (Right v) = Just v
+
+-- | Express device resolution in dot per inch.
+type Dpi = Int
+
+-- | Font size expressed in points.
+-- You must convert size expressed in pixels to point using
+-- the DPI information.
+-- See pixelSizeInPointAtDpi
+newtype PointSize = PointSize { getPointSize :: Float }
+    deriving (Eq, Show)
+
+toPixelCoord :: (Integral a) => Font -> PointSize -> Dpi -> a -> Float
+toPixelCoord font pointSize dpi v =
+    (fromIntegral v * getPointSize pointSize * fromIntegral dpi) /
+    (72 * emSize)
+  where
+    emSize = fromIntegral $ unitsPerEm font
+
+toFCoord :: Integral a => Font -> PointSize -> Dpi -> Float -> a
+toFCoord font size dpi v = floor $ v * emSize / pixelSize
+  where
+    emSize = fromIntegral $ unitsPerEm font
+    pixelSize = size `pointInPixelAtDpi` dpi
+
+
+pointInPixelAtDpi :: PointSize -> Dpi -> Float
+pointInPixelAtDpi size dpi =
+    (getPointSize size * fromIntegral dpi) / 72
+
+pixelSizeInPointAtDpi :: Float -> Dpi -> PointSize
+pixelSizeInPointAtDpi pixelSize dpi =
+    PointSize $ (pixelSize / fromIntegral dpi) * 72
+
+glyphOfStrings :: Font -> String -> [(Glyph, HorizontalMetric)]
+glyphOfStrings Font { _fontMap = Just mapping
+                    , _fontGlyph = Just glyphes
+                    , _fontHorizontalMetrics = Just hmtx } str =
+    fetcher . findCharGlyph mapping 0 <$> str
+  where
+    fetcher ix = (glyphes V.! ix, _glyphMetrics hmtx V.! ix)
+glyphOfStrings _ _ = []
+
+-- | Return the number of pixels relative to the point size.
+unitsPerEm :: Font -> Word16
+unitsPerEm Font { _fontHeader = Just hdr } =
+    fromIntegral $ _fUnitsPerEm hdr
+unitsPerEm  _ = 1
+
+-- | String bounding box. with value for
+-- min/max.
+data BoundingBox = BoundingBox
+  { _xMin :: {-# UNPACK #-} !Float
+  , _yMin :: {-# UNPACK #-} !Float
+  , _xMax :: {-# UNPACK #-} !Float
+  , _yMax :: {-# UNPACK #-} !Float
+    -- | Should be 0 most of the times.
+  , _baselineHeight :: {-# UNPACK #-} !Float
+  }
+  deriving (Eq)
+
+-- | Compute the bounding box of a string displayed with a font at
+-- a given size. The resulting coordinate represent the width and the
+-- height in pixels.
+stringBoundingBox :: Font -> Dpi -> PointSize -> String -> BoundingBox
+stringBoundingBox font dpi size str =
+    BoundingBox xMini yMini width yMaxi 0
+  where
+    glyphs = glyphOfStrings font str
+    xMini = case glyphs of
+        [] -> 0
+        (glyph, _):_ -> toPixel . _glfXMin $ _glyphHeader glyph
+
+    (width, yMini, yMaxi) =
+        foldl' go (0, 0, 0) glyphs
+
+    toPixel :: Integral a => a -> Float
+    toPixel = toPixelCoord font size dpi
+
+    go (xf, yMin, yMax) (glyph, metric) = (width', yMin', yMax')
+      where
+        advance = _hmtxAdvanceWidth metric
+        width' = xf + toPixel advance
+        yMin' = min yMin. toPixel . _glfYMin $ _glyphHeader glyph
+        yMax' = max yMax. toPixel . _glfYMax $ _glyphHeader glyph
+
+
+-- | Extract a list of outlines for every char in the string.
+-- The given curves are in an image like coordinate system,
+-- with the origin point in the upper left corner.
+getStringCurveAtPoint :: Dpi            -- ^ Dot per inch of the output.
+                      -> (Float, Float) -- ^ Initial position of the baseline.
+                      -> [(Font, PointSize, String)] -- ^ Text to draw
+                      -> [[VU.Vector (Float, Float)]] -- ^ List of contours for each char
+getStringCurveAtPoint dpi initPos lst = snd $ mapAccumL go initPos glyphes where
+  glyphes = concat [(font, size,)
+                         <$> glyphOfStrings font str | (font, size, str) <- lst]
+
+  toPixel (font, pointSize, _) = toPixelCoord font pointSize dpi
+  toCoord (font, pointSize, _) = toFCoord font pointSize dpi
+
+  maximumSize = maximum [ toPixel p . _glfYMax $ _glyphHeader glyph
+                                | p@(_, _, (glyph, _)) <- glyphes ]
+
+  go (xf, yf) p@(font, pointSize, (glyph, metric)) = ((toPixel p $ xi + advance, yf), curves)
+    where
+      (xi, yi) = (toCoord p xf, toCoord p yf)
+      bearing = fromIntegral $ _hmtxLeftSideBearing metric
+      advance = fromIntegral $ _hmtxAdvanceWidth metric
+      curves =
+          getGlyphIndexCurvesAtPointSizeAndPos font dpi (toCoord p maximumSize)
+            (pointSize, glyph) (xi + bearing, yi)
+
+-- | This function return the list of all contour for all char with the given
+-- font in a string. All glyph are at the same position, they are not placed
+-- like with `getStringCurveAtPoint`. It is a function helpful to extract
+-- the glyph geometry for further external manipulation.
+getGlyphForStrings :: Dpi -> [(Font, PointSize, String)]
+                   -> [[VU.Vector (Float, Float)]]
+getGlyphForStrings dpi lst =  go <$> glyphes where
+  glyphes = concat
+    [(font, size,) <$> glyphOfStrings font str | (font, size, str) <- lst]
+
+  toCoord (font, pointSize, _) = toFCoord font pointSize dpi
+
+  maximumSize :: Float
+  maximumSize =
+     maximum [ toPixelCoord font pointSize dpi . _glfYMax $ _glyphHeader glyph
+                   | (font, pointSize, (glyph, _)) <- glyphes ]
+
+  go p@(font, pointSize, (glyph, _metric)) =
+    getGlyphIndexCurvesAtPointSizeAndPos
+        font dpi (toCoord p maximumSize) (pointSize, glyph) (0, 0)
+
+getGlyphIndexCurvesAtPointSizeAndPos :: Font -> Dpi -> Int -> (PointSize, Glyph)
+                                     -> (Int, Int)
+                                     -> [VU.Vector (Float, Float)]
+getGlyphIndexCurvesAtPointSizeAndPos Font { _fontHeader = Nothing } _ _ _ _ = []
+getGlyphIndexCurvesAtPointSizeAndPos Font { _fontGlyph = Nothing } _ _ _ _ = []
+getGlyphIndexCurvesAtPointSizeAndPos
+    Font { _fontHeader = Just hdr, _fontGlyph = Just allGlyphs }
+        dpi _maximumSize (pointSize, topGlyph) (baseX, baseY) = glyphFixup <$> glyphExtract topGlyph
+  where
+    go index | index >= V.length allGlyphs = []
+             | otherwise = glyphExtract $ allGlyphs V.! index
+
+    pixelSize = pointSize `pointInPixelAtDpi` dpi
+    emSize = fromIntegral $ _fUnitsPerEm hdr
+
+    glyphFixup = VU.map (\(x,y) ->
+                     ( toPixelCoordinate baseX x
+                     , toPixelCoordinate baseY (-1 * y)
+                     ))
+
+    toFloat v   = fromIntegral v / 0x4000 :: Float
+    fromFloat v = truncate (v * 0x4000)
+
+    toPixelCoordinate shift coord =
+        (fromIntegral (shift + fromIntegral coord) * pixelSize) / emSize
+
+    composeGlyph base composition = VU.map updateCoords <$> subCurves
+      where
+        subCurves = go . fromIntegral $ _glyphCompositeIndex composition
+        CompositeScaling xx xy yx yy = _glyphCompositionScale composition
+        useOffsets                   = _glyphCompositionOffsetArgs composition
+        (e,f)                        = _glyphCompositionArg composition
+
+        -- according to a comment in Freetype's source code, the algorithm given
+        -- in Apple documentation is wrong. We use the same algorithm as
+        -- Freetype except that we go through Float to compute the square root
+        -- instead of staying in Fixed 2.14 (or Fixed 16.16 as in Freetype).
+
+        (xx',xy',yx',yy') = (toFloat xx, toFloat xy, toFloat yx, toFloat yy)
+
+        xscale
+          | xy == 0   = xx'
+          | xx == 0   = xy'
+          | otherwise = sqrt (xx' * xx' + xy' * xy')
+        yscale
+          | yy == 0   = yx'
+          | yx == 0   = yy'
+          | otherwise = sqrt (yx' * yx' + yy' * yy')
+
+        basePoints = VU.concat (_glyphPoints base)
+        (offX,offY)
+          | useOffsets = (e,f)
+          | otherwise  = (fst b1 - fst b2, snd b1 - snd b2)
+               where
+                  b1 = basePoints VU.! (fromIntegral e)
+                  b2 = basePoints VU.! (fromIntegral f)
+
+        updateCoords (x,y) = ( fromFloat (toFloat x * xscale + toFloat offX)
+                             , fromFloat (toFloat y * yscale + toFloat offY)
+                             )
+
+    -- recursively find the base contour of a compound glyph
+    glyphBase g = case _glyphContent g of
+      GlyphEmpty          -> error "Invalid glyph base index"
+      GlyphComposite cs _ ->
+         glyphBase (allGlyphs V.! fromIntegral (_glyphCompositeIndex (V.head cs)))
+      GlyphSimple contour -> contour
+
+    glyphExtract Glyph { _glyphContent = GlyphEmpty } = []
+    glyphExtract g@Glyph { _glyphContent = GlyphComposite compositions _ } =
+        concatMap (composeGlyph (glyphBase g)) $ V.toList compositions
+    glyphExtract Glyph { _glyphContent = GlyphSimple contour } =
+        extractFlatOutline contour
+
+-- | True if the character is not present in the font, therefore it
+-- will appear as a placeholder in renderings.
+isPlaceholder :: Font -> Char -> Bool
+isPlaceholder Font { _fontMap = Just fontMap } character =
+    findCharGlyph fontMap 0 character == 0
+isPlaceholder Font { _fontMap = Nothing } _ = True
+
+-- | Retrive the glyph contours and associated transformations.
+-- The coordinate system is assumed to be the TTF one (y upward).
+-- No transformation is performed.
+getCharacterGlyphsAndMetrics :: Font
+                             -> Char
+                             -> (Float, V.Vector RawGlyph) -- ^ Advance and glyph information.
+getCharacterGlyphsAndMetrics
+    Font { _fontMap = Just mapping
+         , _fontGlyph = Just allGlyphs
+         , _fontHorizontalMetrics = Just hmtx }
+        character =
+    (advance, getCharacterGlyphs allGlyphs allMetrics glyphIndex)
+  where
+    glyphIndex = findCharGlyph mapping 0 character
+    allMetrics = _glyphMetrics hmtx
+    metrics = allMetrics V.! glyphIndex
+    advance = fromIntegral (_hmtxAdvanceWidth metrics)
+getCharacterGlyphsAndMetrics _ _ = (0, mempty)
+
+-- | This type represent unscaled glyph information, everything
+-- is still in its raw form.
+data RawGlyph = RawGlyph
+    { -- | List of transformations to apply to the contour in order
+      -- to get their correct placement.
+      _rawGlyphCompositionScale :: ![CompositeScaling]
+
+      -- | Glyph index in the current font.
+    , _rawGlyphIndex            :: !Int
+
+      -- | Real Geometry of glyph, each vector contain one
+      -- contour.
+    , _rawGlyphContour          :: ![VU.Vector (Int16, Int16)]
+    }
+
+prependScale :: CompositeScaling -> RawGlyph -> RawGlyph
+prependScale scale rGlyph =
+    rGlyph { _rawGlyphCompositionScale = scale : _rawGlyphCompositionScale rGlyph }
+
+getCharacterGlyphs :: V.Vector Glyph -> V.Vector HorizontalMetric -> Int
+                   -> V.Vector RawGlyph
+getCharacterGlyphs allGlyphs allMetrics glyphIndex =
+    case _glyphContent (allGlyphs V.! glyphIndex) of
+      GlyphEmpty -> mempty
+      GlyphComposite compositions _ -> V.concatMap expandComposition compositions
+      GlyphSimple countour ->
+          V.singleton . RawGlyph mempty glyphIndex $ extractFlatOutline countour
+  where
+    recurse = getCharacterGlyphs allGlyphs allMetrics 
+
+    expandComposition GlyphComposition { _glyphCompositeIndex = index
+                                       , _glyphCompositionScale = scale } =
+      V.map (prependScale scale) . recurse $ fromIntegral index
+

src/Graphics/Text/TrueType/Bytecode.hs view

@@ -1,448 +1,448 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.Bytecode where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>) )-import Data.Monoid( mempty )-#endif--import Prelude hiding ( EQ, GT, LT )-{-import Control.Monad.State.Strict( modify )-}-import Data.Bits( (.&.), testBit )-import Data.Binary.Get( Get, getWord8, getWord16be )-import Data.Int( Int32 )-import qualified Data.Map as M-import Data.Word( Word8, Word16 )-import qualified Data.Vector.Unboxed as VU--import Graphics.Text.TrueType.Types--type InstructionFlag = Bool--data Instruction-    -- | Pop one argument from the stack-    = AA -    | ABS-    | ADD-    | ALIGNPTS-    | ALIGNRP-    | AND-    | CALL-    | CEILING-    | CINDEX-    | CLEAR-    | DEBUG-    | DELTAC1-    | DELTAC2-    | DELTAC3-    | DELTAP1-    | DELTAP2-    | DELTAP3-    | DEPTH-    | DIV-    | DUP-    | EIF-    | ELSE-    | ENDF-    | EQ-    | EVEN-    | FDEF-    | FLIPOFF-    | FLIPON-    | FLIPPT-    | FLIPRGOFF-    | FLIPRGON-    | FLOOR-    | GC PositionSource-    | GETINFO-      -- | Get Freedom vector-    | GFV-    | GPV-    | GT-    | GTEQ-    | IDEF-    | IF-    | INSTCTRL-    | IP-    | ISECT-    | IUP Direction-    | JMPR-    | JROF-    | JROT-    | LOOPCALL-    | LT-    | LTEQ-    | MAX-    | MD PositionSource-    | MDAP Rounding-    | MDRP PointReset DistanceKeeping Rounding Word8-    | MIAP Rounding-    | MIN-    | MINDEX-    | MIRP PointReset DistanceKeeping Rounding Word8-    | MPPEM-    | MPS-    | MSIRP PointReset-    | MUL-    | NEG-    | NEQ-    | NOT-    | NPUSHB (VU.Vector Word8)-    | NPUSHW (VU.Vector Word16)-    | NROUND Word8-    | ODD-    | OR-    | POP-    | PUSHB (VU.Vector Word8)-    | PUSHW (VU.Vector Word16)-    | RCVT-    | RDTG-    | ROFF-    | ROLL-    | ROUND Word8-    | RS-    | RTDG-    | RTG-    | RTHG-    | RUTG-    | S45ROUND-    | SANGW-    | SCANCTRL-    | SCANTYPE-    | SCFS-    | SCVTCI-    | SDB-    | SDPVTL Parallelism-    | SDS-    | SFVFS-    | SFVTCA Direction-    | SFVTL Parallelism-    | SFVTPV-    | SHC CountourRef-    | SHP CountourRef-    | SHPIX-    | SHZ CountourRef-    | SLOOP-    | SMD-    | SPVFS-    | SPVTCA Direction-    | SPVTL Parallelism-    | SROUND-    | SRP0-    | SRP1-    | SRP2-    | SSW-    | SSWCI-    | SUB-    | SVTCA Direction-    | SWAP-    | SZP0-    | SZP1-    | SZP2-    | SZPS-    | UTP-    | WCVTF-    | WCVTP-    | WS-    deriving (Eq, Show)--data CountourRef-    = UseRP2InZP1-    | UseRP1InZP0-    deriving (Eq, Show)--data Parallelism-    = VectorParallel-    | VectorPerpendicular-    deriving (Eq, Show)--data PositionSource-    = PositionCurrent-    | PositionOriginal-    deriving (Eq, Show)--data Direction-    = DirectionX-    | DirectionY-    deriving (Eq, Show)--data Rounding-    = RoundingNone-    | Rounding-    deriving (Eq, Show)--data PointReset-    = ResetNot-    | ResetRP0-    deriving (Eq, Show)--data DistanceKeeping-    = DistanceFree-    | DistanceGreaterThanMin-    deriving (Eq, Show)--data ByteCodeProgram-    = If     [ByteCodeProgram]-    | IfElse [ByteCodeProgram] [ByteCodeProgram]-    | Function [ByteCodeProgram]-    | Sequence [Instruction]-    deriving (Eq, Show)--instructionToProgram :: [Instruction]-> [ByteCodeProgram]-instructionToProgram = firstOfThird . go []-  where-    firstOfThird (f, _, _) = f--    go acc [] = (reverse acc, [], [])-    go acc (IF : rest) =-      case go [] rest of-        (ifBranch, [], final) -> go (If ifBranch : acc) final-        (ifBranch, elseBranch, final) ->-            go (IfElse ifBranch elseBranch : acc) final-    go acc (EIF : rest) = (reverse acc, [], rest)-    go acc (ELSE : rest) = (acc, elseBranch, final)-      where (elseBranch, _, final) = go [] rest-    go acc (FDEF : rest) = go (Function def: acc) final-      where (def, _, final) = go [] rest-    go acc (ENDF : rest) = (reverse acc, [], rest)-    go acc (x : xs) = go (Sequence [x] : acc) xs---inRange :: Ord a => a -> (a, a) -> Bool-inRange v (lo, hi) = lo <= v && v <= hi--getInstr :: Get Instruction -getInstr = getWord8 >>= go-  where-    mirpParse x constructor = constructor reset distance rounding distanceType-      where-        reset | x `testBit` 4 = ResetRP0-              | otherwise = ResetNot--        distance | x `testBit` 3 = DistanceGreaterThanMin-                 | otherwise = DistanceFree--        rounding | x `testBit` 2 = Rounding-                 | otherwise = RoundingNone--        distanceType = x .&. 0x3--    go w = case w of-      0x7F -> return AA-      0x64 -> return ABS-      0x60 -> return ADD-      0x27 -> return ALIGNPTS-      0x3C -> return ALIGNRP-      0x5A -> return AND-      0x2B -> return CALL-      0x67 -> return CEILING-      0x25 -> return CINDEX-      0x22 -> return CLEAR-      0x4F -> return DEBUG-      0x73 -> return DELTAC1-      0x74 -> return DELTAC2-      0x75 -> return DELTAC3-      0x5D -> return DELTAP1-      0x71 -> return DELTAP2-      0x72 -> return DELTAP3-      0x24 -> return DEPTH-      0x62 -> return DIV-      0x20 -> return DUP-      0x59 -> return EIF-      0x1B -> return ELSE-      0x2D -> return ENDF-      0x54 -> return EQ-      0x57 -> return EVEN-      0x2C -> return FDEF-      0x4E -> return FLIPOFF-      0x4D -> return FLIPON-      0x80 -> return FLIPPT-      0x82 -> return FLIPRGOFF-      0x81 -> return FLIPRGON-      0x66 -> return FLOOR-      0x46 -> return $ GC PositionCurrent-      0x47 -> return $ GC PositionOriginal-      0x88 -> return GETINFO-      0x0D -> return GFV-      0x0C -> return GPV-      0x52 -> return GT-      0x53 -> return GTEQ-      0x89 -> return IDEF-      0x58 -> return IF-      0x8E -> return INSTCTRL-      0x39 -> return IP-      0x0F -> return ISECT-      0x30 -> return $ IUP DirectionY-      0x31 -> return $ IUP DirectionX-      0x1C -> return JMPR-      0x79 -> return JROF-      0x78 -> return JROT-      0x2A -> return LOOPCALL-      0x50 -> return LT-      0x51 -> return LTEQ-      0x8B -> return MAX-      0x49 -> return $ MD PositionCurrent-      0x4A -> return $ MD PositionOriginal-      0x2E -> return $ MDAP RoundingNone-      0x2F -> return $ MDAP Rounding-      x | x `inRange` (0xC0, 0xDF) -> return $ mirpParse x MDRP-      0x3E -> return $ MIAP RoundingNone-      0x3F -> return $ MIAP Rounding-      0x8C -> return MIN-      0x26 -> return MINDEX-      x | x `inRange` (0xE0, 0xFF) -> return $ mirpParse x MIRP-      0x4B -> return MPPEM-      0x4C -> return MPS-      0x3A -> return $ MSIRP ResetNot-      0x3B -> return $ MSIRP ResetRP0-      0x63 -> return MUL-      0x65 -> return NEG-      0x55 -> return NEQ-      0x5C -> return NOT-      0x40 -> do-        count <- fromIntegral <$> getWord8-        NPUSHB <$> VU.replicateM count getWord8--      0x41 -> do-        count <- fromIntegral <$> getWord8-        NPUSHW <$> VU.replicateM count getWord16be-      x | x `inRange` (0x6C, 0x6F) ->-          return . NROUND $ x .&. 3-      0x56 -> return ODD-      0x5B -> return OR-      0x21 -> return POP-      x | x `inRange` (0xB0, 0xB7) -> do-          let count = fromIntegral $ (x .&. 0x7) + 1-          PUSHB <$> VU.replicateM count getWord8-      x | x `inRange` (0xB8, 0xBF) -> do-          let count = fromIntegral $ (x .&. 0x7) + 1-          PUSHW <$> VU.replicateM count getWord16be-      0x45 -> return RCVT-      0x7D -> return RDTG-      0x7A -> return ROFF-      0x8A -> return ROLL-      x | x `inRange` (0x68, 0x6B) ->-          return $ ROUND (x .&. 0x3)-      0x43 -> return RS-      0x3D -> return RTDG-      0x18 -> return RTG-      0x19 -> return RTHG-      0x7C -> return RUTG-      0x77 -> return S45ROUND-      0x7E -> return SANGW-      0x85 -> return SCANCTRL-      0x8D -> return SCANTYPE-      0x48 -> return SCFS-      0x1D -> return SCVTCI-      0x5E -> return SDB-      0x86 -> return $ SDPVTL VectorParallel-      0x87 -> return $ SDPVTL VectorPerpendicular-      0x5F -> return SDS-      0x0B -> return SFVFS-      0x04 -> return $ SFVTCA DirectionY-      0x05 -> return $ SFVTCA DirectionX-      0x08 -> return $ SFVTL VectorParallel-      0x09 -> return $ SFVTL VectorPerpendicular-      0x0E -> return SFVTPV-      0x34 -> return $ SHC UseRP2InZP1-      0x35 -> return $ SHC UseRP1InZP0-      0x32 -> return $ SHP UseRP2InZP1-      0x33 -> return $ SHP UseRP1InZP0-      0x38 -> return SHPIX-      0x36 -> return $ SHZ UseRP2InZP1-      0x37 -> return $ SHZ UseRP1InZP0-      0x17 -> return SLOOP-      0x1A -> return SMD-      0x0A -> return SPVFS-      0x02 -> return $ SPVTCA DirectionY-      0x03 -> return $ SPVTCA DirectionX-      0x06 -> return $ SPVTL VectorParallel-      0x07 -> return $ SPVTL VectorPerpendicular-      0x76 -> return SROUND-      0x10 -> return SRP0-      0x11 -> return SRP1-      0x12 -> return SRP2-      0x1F -> return SSW-      0x1E -> return SSWCI-      0x61 -> return SUB-      0x00 -> return $ SVTCA DirectionY-      0x01 -> return $ SVTCA DirectionX-      0x23 -> return SWAP-      0x13 -> return SZP0-      0x14 -> return SZP1-      0x15 -> return SZP2-      0x16 -> return SZPS-      0x29 -> return UTP-      0x70 -> return WCVTF-      0x44 -> return WCVTP-      0x42 -> return WS-      _ -> fail "instruction reader coverage pleaser"--type Point = (F26Dot6, F26Dot6)--data GraphicalState = GraphicalState-    { _stAutoFlip           :: !Bool-    , _stCutIn              :: {-# UNPACK #-} !F26Dot6-    , _stDeltaBase          :: {-# UNPACK #-} !Int32-    , _stDeltaShift         :: {-# UNPACK #-} !Int32-    , _stDualProjection     :: !(Maybe Point)-    , _stFreedomVector      :: !Point-    , _stInstructionControl :: !Bool-    , _stLoop               :: {-# UNPACK #-} !Int32-    , _stMinDistance        :: {-# UNPACK #-} !F26Dot6-    , _stProjectionVector   :: !Point-    , _stRoundState         :: {-# UNPACK #-} !Int32-    , _stRp0                :: {-# UNPACK #-} !Int32-    , _stRp1                :: {-# UNPACK #-} !Int32-    , _stRp2                :: {-# UNPACK #-} !Int32-    , _stScanControl        :: !Bool-    , _stSingleWidthCutIn   :: {-# UNPACK #-} !F26Dot6-    , _stSingleWidthValue   :: {-# UNPACK #-} !F26Dot6-    , _stZp0                :: {-# UNPACK #-} !Int32-    , _stZp1                :: {-# UNPACK #-} !Int32-    , _stZp2                :: {-# UNPACK #-} !Int32-    , _stFunctions          :: !(M.Map Int32 [ByteCodeProgram])-    }-    deriving (Eq, Show)--initialState :: GraphicalState-initialState = GraphicalState-    { _stAutoFlip  = True-    , _stCutIn     = 17 / 16-    , _stDeltaBase = 9-    , _stDeltaShift = 3-    , _stDualProjection = Nothing-    , _stFreedomVector = (1, 0)-    , _stInstructionControl = False-    , _stLoop = 1-    , _stMinDistance = 1-    , _stProjectionVector = (1, 0)-    , _stRoundState = 1-    , _stRp0 = 0-    , _stRp1 = 0-    , _stRp2 = 0-    , _stScanControl = False-    , _stSingleWidthCutIn = 0-    , _stSingleWidthValue = 0-    , _stZp0 = 1-    , _stZp1 = 1-    , _stZp2 = 1-    , _stFunctions = mempty-    }--#if 0--evaluate :: [ByteCodeProgram] -> ()-evaluate instrs =-  where-    byteExec []                        stack = stack-    byteExec (If        _ : instr) (0:stack) = byteExec instr stack-    byteExec (If thenBody : instr) (_:stack) = byteExec (thenBody ++ instr) stack-    byteExec (IfElse _ elseBody)   (0:stack) = byteExec (elseBody ++ instr) stack-    byteExec (IfElse thenBody _)   (_:stack) = byteExec (thenBody ++ instr) stack-    byteExec (Function functionBody : instr) (id:stack) =-        modify (\s -> s { _stFunctions = M.add id functionBody }) >> byteExec instr stack-    byteExec (Sequence intructions : rest) stack = go instructions stack >>= byteExec rest--#endif-+{-# LANGUAGE CPP #-}
+module Graphics.Text.TrueType.Bytecode where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<$>) )
+import Data.Monoid( mempty )
+#endif
+
+import Prelude hiding ( EQ, GT, LT )
+{-import Control.Monad.State.Strict( modify )-}
+import Data.Bits( (.&.), testBit )
+import Data.Binary.Get( Get, getWord8, getWord16be )
+import Data.Int( Int32 )
+import qualified Data.Map as M
+import Data.Word( Word8, Word16 )
+import qualified Data.Vector.Unboxed as VU
+
+import Graphics.Text.TrueType.Types
+
+type InstructionFlag = Bool
+
+data Instruction
+    -- | Pop one argument from the stack
+    = AA 
+    | ABS
+    | ADD
+    | ALIGNPTS
+    | ALIGNRP
+    | AND
+    | CALL
+    | CEILING
+    | CINDEX
+    | CLEAR
+    | DEBUG
+    | DELTAC1
+    | DELTAC2
+    | DELTAC3
+    | DELTAP1
+    | DELTAP2
+    | DELTAP3
+    | DEPTH
+    | DIV
+    | DUP
+    | EIF
+    | ELSE
+    | ENDF
+    | EQ
+    | EVEN
+    | FDEF
+    | FLIPOFF
+    | FLIPON
+    | FLIPPT
+    | FLIPRGOFF
+    | FLIPRGON
+    | FLOOR
+    | GC PositionSource
+    | GETINFO
+      -- | Get Freedom vector
+    | GFV
+    | GPV
+    | GT
+    | GTEQ
+    | IDEF
+    | IF
+    | INSTCTRL
+    | IP
+    | ISECT
+    | IUP Direction
+    | JMPR
+    | JROF
+    | JROT
+    | LOOPCALL
+    | LT
+    | LTEQ
+    | MAX
+    | MD PositionSource
+    | MDAP Rounding
+    | MDRP PointReset DistanceKeeping Rounding Word8
+    | MIAP Rounding
+    | MIN
+    | MINDEX
+    | MIRP PointReset DistanceKeeping Rounding Word8
+    | MPPEM
+    | MPS
+    | MSIRP PointReset
+    | MUL
+    | NEG
+    | NEQ
+    | NOT
+    | NPUSHB (VU.Vector Word8)
+    | NPUSHW (VU.Vector Word16)
+    | NROUND Word8
+    | ODD
+    | OR
+    | POP
+    | PUSHB (VU.Vector Word8)
+    | PUSHW (VU.Vector Word16)
+    | RCVT
+    | RDTG
+    | ROFF
+    | ROLL
+    | ROUND Word8
+    | RS
+    | RTDG
+    | RTG
+    | RTHG
+    | RUTG
+    | S45ROUND
+    | SANGW
+    | SCANCTRL
+    | SCANTYPE
+    | SCFS
+    | SCVTCI
+    | SDB
+    | SDPVTL Parallelism
+    | SDS
+    | SFVFS
+    | SFVTCA Direction
+    | SFVTL Parallelism
+    | SFVTPV
+    | SHC CountourRef
+    | SHP CountourRef
+    | SHPIX
+    | SHZ CountourRef
+    | SLOOP
+    | SMD
+    | SPVFS
+    | SPVTCA Direction
+    | SPVTL Parallelism
+    | SROUND
+    | SRP0
+    | SRP1
+    | SRP2
+    | SSW
+    | SSWCI
+    | SUB
+    | SVTCA Direction
+    | SWAP
+    | SZP0
+    | SZP1
+    | SZP2
+    | SZPS
+    | UTP
+    | WCVTF
+    | WCVTP
+    | WS
+    deriving (Eq, Show)
+
+data CountourRef
+    = UseRP2InZP1
+    | UseRP1InZP0
+    deriving (Eq, Show)
+
+data Parallelism
+    = VectorParallel
+    | VectorPerpendicular
+    deriving (Eq, Show)
+
+data PositionSource
+    = PositionCurrent
+    | PositionOriginal
+    deriving (Eq, Show)
+
+data Direction
+    = DirectionX
+    | DirectionY
+    deriving (Eq, Show)
+
+data Rounding
+    = RoundingNone
+    | Rounding
+    deriving (Eq, Show)
+
+data PointReset
+    = ResetNot
+    | ResetRP0
+    deriving (Eq, Show)
+
+data DistanceKeeping
+    = DistanceFree
+    | DistanceGreaterThanMin
+    deriving (Eq, Show)
+
+data ByteCodeProgram
+    = If     [ByteCodeProgram]
+    | IfElse [ByteCodeProgram] [ByteCodeProgram]
+    | Function [ByteCodeProgram]
+    | Sequence [Instruction]
+    deriving (Eq, Show)
+
+instructionToProgram :: [Instruction]-> [ByteCodeProgram]
+instructionToProgram = firstOfThird . go []
+  where
+    firstOfThird (f, _, _) = f
+
+    go acc [] = (reverse acc, [], [])
+    go acc (IF : rest) =
+      case go [] rest of
+        (ifBranch, [], final) -> go (If ifBranch : acc) final
+        (ifBranch, elseBranch, final) ->
+            go (IfElse ifBranch elseBranch : acc) final
+    go acc (EIF : rest) = (reverse acc, [], rest)
+    go acc (ELSE : rest) = (acc, elseBranch, final)
+      where (elseBranch, _, final) = go [] rest
+    go acc (FDEF : rest) = go (Function def: acc) final
+      where (def, _, final) = go [] rest
+    go acc (ENDF : rest) = (reverse acc, [], rest)
+    go acc (x : xs) = go (Sequence [x] : acc) xs
+
+
+inRange :: Ord a => a -> (a, a) -> Bool
+inRange v (lo, hi) = lo <= v && v <= hi
+
+getInstr :: Get Instruction 
+getInstr = getWord8 >>= go
+  where
+    mirpParse x constructor = constructor reset distance rounding distanceType
+      where
+        reset | x `testBit` 4 = ResetRP0
+              | otherwise = ResetNot
+
+        distance | x `testBit` 3 = DistanceGreaterThanMin
+                 | otherwise = DistanceFree
+
+        rounding | x `testBit` 2 = Rounding
+                 | otherwise = RoundingNone
+
+        distanceType = x .&. 0x3
+
+    go w = case w of
+      0x7F -> return AA
+      0x64 -> return ABS
+      0x60 -> return ADD
+      0x27 -> return ALIGNPTS
+      0x3C -> return ALIGNRP
+      0x5A -> return AND
+      0x2B -> return CALL
+      0x67 -> return CEILING
+      0x25 -> return CINDEX
+      0x22 -> return CLEAR
+      0x4F -> return DEBUG
+      0x73 -> return DELTAC1
+      0x74 -> return DELTAC2
+      0x75 -> return DELTAC3
+      0x5D -> return DELTAP1
+      0x71 -> return DELTAP2
+      0x72 -> return DELTAP3
+      0x24 -> return DEPTH
+      0x62 -> return DIV
+      0x20 -> return DUP
+      0x59 -> return EIF
+      0x1B -> return ELSE
+      0x2D -> return ENDF
+      0x54 -> return EQ
+      0x57 -> return EVEN
+      0x2C -> return FDEF
+      0x4E -> return FLIPOFF
+      0x4D -> return FLIPON
+      0x80 -> return FLIPPT
+      0x82 -> return FLIPRGOFF
+      0x81 -> return FLIPRGON
+      0x66 -> return FLOOR
+      0x46 -> return $ GC PositionCurrent
+      0x47 -> return $ GC PositionOriginal
+      0x88 -> return GETINFO
+      0x0D -> return GFV
+      0x0C -> return GPV
+      0x52 -> return GT
+      0x53 -> return GTEQ
+      0x89 -> return IDEF
+      0x58 -> return IF
+      0x8E -> return INSTCTRL
+      0x39 -> return IP
+      0x0F -> return ISECT
+      0x30 -> return $ IUP DirectionY
+      0x31 -> return $ IUP DirectionX
+      0x1C -> return JMPR
+      0x79 -> return JROF
+      0x78 -> return JROT
+      0x2A -> return LOOPCALL
+      0x50 -> return LT
+      0x51 -> return LTEQ
+      0x8B -> return MAX
+      0x49 -> return $ MD PositionCurrent
+      0x4A -> return $ MD PositionOriginal
+      0x2E -> return $ MDAP RoundingNone
+      0x2F -> return $ MDAP Rounding
+      x | x `inRange` (0xC0, 0xDF) -> return $ mirpParse x MDRP
+      0x3E -> return $ MIAP RoundingNone
+      0x3F -> return $ MIAP Rounding
+      0x8C -> return MIN
+      0x26 -> return MINDEX
+      x | x `inRange` (0xE0, 0xFF) -> return $ mirpParse x MIRP
+      0x4B -> return MPPEM
+      0x4C -> return MPS
+      0x3A -> return $ MSIRP ResetNot
+      0x3B -> return $ MSIRP ResetRP0
+      0x63 -> return MUL
+      0x65 -> return NEG
+      0x55 -> return NEQ
+      0x5C -> return NOT
+      0x40 -> do
+        count <- fromIntegral <$> getWord8
+        NPUSHB <$> VU.replicateM count getWord8
+
+      0x41 -> do
+        count <- fromIntegral <$> getWord8
+        NPUSHW <$> VU.replicateM count getWord16be
+      x | x `inRange` (0x6C, 0x6F) ->
+          return . NROUND $ x .&. 3
+      0x56 -> return ODD
+      0x5B -> return OR
+      0x21 -> return POP
+      x | x `inRange` (0xB0, 0xB7) -> do
+          let count = fromIntegral $ (x .&. 0x7) + 1
+          PUSHB <$> VU.replicateM count getWord8
+      x | x `inRange` (0xB8, 0xBF) -> do
+          let count = fromIntegral $ (x .&. 0x7) + 1
+          PUSHW <$> VU.replicateM count getWord16be
+      0x45 -> return RCVT
+      0x7D -> return RDTG
+      0x7A -> return ROFF
+      0x8A -> return ROLL
+      x | x `inRange` (0x68, 0x6B) ->
+          return $ ROUND (x .&. 0x3)
+      0x43 -> return RS
+      0x3D -> return RTDG
+      0x18 -> return RTG
+      0x19 -> return RTHG
+      0x7C -> return RUTG
+      0x77 -> return S45ROUND
+      0x7E -> return SANGW
+      0x85 -> return SCANCTRL
+      0x8D -> return SCANTYPE
+      0x48 -> return SCFS
+      0x1D -> return SCVTCI
+      0x5E -> return SDB
+      0x86 -> return $ SDPVTL VectorParallel
+      0x87 -> return $ SDPVTL VectorPerpendicular
+      0x5F -> return SDS
+      0x0B -> return SFVFS
+      0x04 -> return $ SFVTCA DirectionY
+      0x05 -> return $ SFVTCA DirectionX
+      0x08 -> return $ SFVTL VectorParallel
+      0x09 -> return $ SFVTL VectorPerpendicular
+      0x0E -> return SFVTPV
+      0x34 -> return $ SHC UseRP2InZP1
+      0x35 -> return $ SHC UseRP1InZP0
+      0x32 -> return $ SHP UseRP2InZP1
+      0x33 -> return $ SHP UseRP1InZP0
+      0x38 -> return SHPIX
+      0x36 -> return $ SHZ UseRP2InZP1
+      0x37 -> return $ SHZ UseRP1InZP0
+      0x17 -> return SLOOP
+      0x1A -> return SMD
+      0x0A -> return SPVFS
+      0x02 -> return $ SPVTCA DirectionY
+      0x03 -> return $ SPVTCA DirectionX
+      0x06 -> return $ SPVTL VectorParallel
+      0x07 -> return $ SPVTL VectorPerpendicular
+      0x76 -> return SROUND
+      0x10 -> return SRP0
+      0x11 -> return SRP1
+      0x12 -> return SRP2
+      0x1F -> return SSW
+      0x1E -> return SSWCI
+      0x61 -> return SUB
+      0x00 -> return $ SVTCA DirectionY
+      0x01 -> return $ SVTCA DirectionX
+      0x23 -> return SWAP
+      0x13 -> return SZP0
+      0x14 -> return SZP1
+      0x15 -> return SZP2
+      0x16 -> return SZPS
+      0x29 -> return UTP
+      0x70 -> return WCVTF
+      0x44 -> return WCVTP
+      0x42 -> return WS
+      _ -> fail "instruction reader coverage pleaser"
+
+type Point = (F26Dot6, F26Dot6)
+
+data GraphicalState = GraphicalState
+    { _stAutoFlip           :: !Bool
+    , _stCutIn              :: {-# UNPACK #-} !F26Dot6
+    , _stDeltaBase          :: {-# UNPACK #-} !Int32
+    , _stDeltaShift         :: {-# UNPACK #-} !Int32
+    , _stDualProjection     :: !(Maybe Point)
+    , _stFreedomVector      :: !Point
+    , _stInstructionControl :: !Bool
+    , _stLoop               :: {-# UNPACK #-} !Int32
+    , _stMinDistance        :: {-# UNPACK #-} !F26Dot6
+    , _stProjectionVector   :: !Point
+    , _stRoundState         :: {-# UNPACK #-} !Int32
+    , _stRp0                :: {-# UNPACK #-} !Int32
+    , _stRp1                :: {-# UNPACK #-} !Int32
+    , _stRp2                :: {-# UNPACK #-} !Int32
+    , _stScanControl        :: !Bool
+    , _stSingleWidthCutIn   :: {-# UNPACK #-} !F26Dot6
+    , _stSingleWidthValue   :: {-# UNPACK #-} !F26Dot6
+    , _stZp0                :: {-# UNPACK #-} !Int32
+    , _stZp1                :: {-# UNPACK #-} !Int32
+    , _stZp2                :: {-# UNPACK #-} !Int32
+    , _stFunctions          :: !(M.Map Int32 [ByteCodeProgram])
+    }
+    deriving (Eq, Show)
+
+initialState :: GraphicalState
+initialState = GraphicalState
+    { _stAutoFlip  = True
+    , _stCutIn     = 17 / 16
+    , _stDeltaBase = 9
+    , _stDeltaShift = 3
+    , _stDualProjection = Nothing
+    , _stFreedomVector = (1, 0)
+    , _stInstructionControl = False
+    , _stLoop = 1
+    , _stMinDistance = 1
+    , _stProjectionVector = (1, 0)
+    , _stRoundState = 1
+    , _stRp0 = 0
+    , _stRp1 = 0
+    , _stRp2 = 0
+    , _stScanControl = False
+    , _stSingleWidthCutIn = 0
+    , _stSingleWidthValue = 0
+    , _stZp0 = 1
+    , _stZp1 = 1
+    , _stZp2 = 1
+    , _stFunctions = mempty
+    }
+
+#if 0
+
+evaluate :: [ByteCodeProgram] -> ()
+evaluate instrs =
+  where
+    byteExec []                        stack = stack
+    byteExec (If        _ : instr) (0:stack) = byteExec instr stack
+    byteExec (If thenBody : instr) (_:stack) = byteExec (thenBody ++ instr) stack
+    byteExec (IfElse _ elseBody)   (0:stack) = byteExec (elseBody ++ instr) stack
+    byteExec (IfElse thenBody _)   (_:stack) = byteExec (thenBody ++ instr) stack
+    byteExec (Function functionBody : instr) (id:stack) =
+        modify (\s -> s { _stFunctions = M.add id functionBody }) >> byteExec instr stack
+    byteExec (Sequence intructions : rest) stack = go instructions stack >>= byteExec rest
+
+#endif
+

src/Graphics/Text/TrueType/CharacterMap.hs view

@@ -1,385 +1,385 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.CharacterMap-    ( TtfEncoding( .. )-    , CharacterMaps-    , LangId-    , findCharGlyph-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-#endif--import Control.DeepSeq( NFData( .. ) )-import Control.Monad( replicateM,  when, foldM  )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( Get-                      , skip-                      , bytesRead-                      , getWord8-                      , getWord16be-                      , getWord32be )--import Data.Binary.Put( putWord16be-                      , putWord32be )-import Data.Int( Int16 )-import Data.List( find, sort, sortBy )-import qualified Data.Map.Strict as M-import Data.Maybe( fromMaybe )-import Data.Word( Word8, Word16, Word32 )-import Data.Ord( comparing )--import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as VU--import Graphics.Text.TrueType.LanguageIds---------------------------------------------------------            TtfEncoding----------------------------------------------------data TtfEncoding-  = EncodingSymbol-  | EncodingUnicode-  | EncodingShiftJIS-  | EncodingBig5-  | EncodingPRC-  | EncodingWansung-  | EncodingJohab-  deriving (Eq, Show)--instance Binary TtfEncoding where-    put EncodingSymbol = putWord16be 0-    put EncodingUnicode = putWord16be 1-    put EncodingShiftJIS = putWord16be 2-    put EncodingBig5 = putWord16be 3-    put EncodingPRC = putWord16be 4-    put EncodingWansung = putWord16be 5-    put EncodingJohab = putWord16be 6--    get = do-      v <- getWord16be-      case v of-        0 -> return EncodingSymbol-        1 -> return EncodingUnicode-        2 -> return EncodingShiftJIS-        3 -> return EncodingBig5-        4 -> return EncodingPRC-        5 -> return EncodingWansung-        6 -> return EncodingJohab-        _ -> fail "Unknown encoding"--class CharMappeable a where-  -- | Given a group a character, return a valid glyph-  -- id and the rest of the string.-  glyphIdFromTable :: a -> Char -> Int--  -- | Given a table, retrieve the language code-  langIdOfCharMap :: a -> LangId--type LangId = Word16---------------------------------------------------------            CharacterMaps----------------------------------------------------data CharacterMap = CharacterMap-    { _charMapPlatformId       :: !PlatformId-    , _charMapPlatformSpecific :: !Word16-    , _charMap                 :: !CharacterTable-    }-    deriving (Eq, Show)--instance NFData CharacterMap where-  rnf (CharacterMap {}) = ()--instance Ord CharacterMap where-    compare = comparing _charMap--newtype CharacterMaps = CharacterMaps [CharacterMap]-    deriving (Eq, Show)--instance NFData CharacterMaps where-  rnf (CharacterMaps maps) = rnf maps `seq` ()--instance Binary CharacterMaps where-  put _ = fail "Unimplemented"-  get = do-      startIndex <- bytesRead-      versionNumber <- getWord16be-      when (versionNumber /= 0)-           (fail "Characte map - invalid version number")-      tableCount <- fromIntegral <$> getWord16be-      let descFetcher = (,,) <$> get <*> getWord16be <*> getWord32be-          third (_, _, t) = t-      tableDesc <--          sortBy (comparing third) <$> replicateM tableCount descFetcher-          --      let fetcher (allMaps, lst) (platformId, platformSpecific, offset)-              | M.member offset allMaps = case M.lookup offset allMaps of-                  Nothing -> fail "Impossible"-                  Just table ->-                      return (allMaps, CharacterMap platformId platformSpecific table : lst)-          fetcher (allMaps, lst) (platformId, platformSpecific, offset) = do-              currentOffset <- fromIntegral <$> bytesRead-              let toSkip = fromIntegral offset - currentOffset + startIndex-              when (toSkip > 0)-                  (skip $ fromIntegral toSkip)-              mapData <- get-              let charMap = CharacterMap platformId platformSpecific mapData-              return (M.insert offset mapData allMaps, charMap : lst)- -      (_, tables) <- foldM fetcher (M.empty, []) tableDesc-      return . CharacterMaps $ sortBy (comparing _charMap) tables--data CharMapOffset = CharMapOffset-    { _cmoPlatformId :: !Word16-    , _cmoEncodingId :: !TtfEncoding-    , _cmoOffset     :: !Word32-    }-    deriving (Eq, Show)--instance Binary CharMapOffset where-    get = CharMapOffset <$> getWord16be <*> get <*> getWord32be-    put (CharMapOffset platform encoding offset) =-      putWord16be platform >> put encoding >> putWord32be offset---------------------------------------------------------            CharacterTable----------------------------------------------------data CharacterTable-    = TableFormat0 !Format0-    | TableFormat2 !Format2-    | TableFormat4 !Format4-    | TableFormat6 !Format6-    | TableFormatUnknown !Word16-    deriving (Eq, Show)--charTableMap :: (forall table . (CharMappeable table) => table -> a)-             -> CharacterTable -> a-charTableMap f = go-  where-    go (TableFormat0 t) = f t-    go (TableFormat2 t) = f t-    go (TableFormat4 t) = f t-    go (TableFormat6 t) = f t-    go (TableFormatUnknown v) = f v--findCharGlyph :: CharacterMaps -> LangId -> Char -> Int-findCharGlyph (CharacterMaps charMaps) langId character =-    fromMaybe 0 . find (/= 0) . map snd . sort $-        [(_charMapPlatformId allMap, charTableMap (`glyphIdFromTable` character) m)-                | allMap <- charMaps-                , let m = _charMap allMap-                , isLangCompatible m]-  where-    isLangCompatible v = tableLang == 0 || tableLang == langId -      where tableLang = charTableMap langIdOfCharMap v--instance Ord CharacterTable where-    compare (TableFormat0 v1) (TableFormat0 v2) =-        comparing langIdOfCharMap v1 v2-    compare (TableFormat2 v1) (TableFormat2 v2) =-        comparing langIdOfCharMap v1 v2-    compare (TableFormat4 v1) (TableFormat4 v2) =-        comparing langIdOfCharMap v1 v2-    compare (TableFormat6 v1) (TableFormat6 v2) =-        comparing langIdOfCharMap v1 v2-    compare (TableFormat0 _) _ = LT-    compare (TableFormat2 _) _ = LT-    compare (TableFormat4 _) _ = LT-    compare (TableFormat6 _) _ = LT-    compare _ _ = GT--instance Binary CharacterTable where-    put _ = fail "Binary.put CharacterTable - Unimplemented"-    get = do-      format <- getWord16be-      case format of-        0 -> TableFormat0 <$> get-        2 -> TableFormat2 <$> get-        4 -> TableFormat4 <$> get-        6 -> TableFormat6 <$> get-        n -> return $ TableFormatUnknown n--instance CharMappeable Word16 where-  glyphIdFromTable _ _ = 0-  langIdOfCharMap _ = 0----------------------------------------------------------            Format4----------------------------------------------------data Format4 = Format4-    { _f4Language :: {-# UNPACK #-} !LangId-    , _f4Map :: M.Map Word16 Word16-    }-    deriving (Eq, Show)--instance CharMappeable Format4 where-  glyphIdFromTable tab v =-      fromIntegral . M.findWithDefault 0 wc $ _f4Map tab-        where wc = fromIntegral $ fromEnum v-  langIdOfCharMap = _f4Language--instance Binary Format4 where-  put _ = error "put Format4 - unimplemented"-  get = do-      startIndex <- bytesRead-      tableLength <- fromIntegral <$> getWord16be-      language <- getWord16be-      -- 2 * segCount-      segCount <- (`div` 2) . fromIntegral <$> getWord16be-      -- 2 * (2**FLOOR(log2(segCount)))-      _searchRange <- getWord16be-      -- log2(searchRange/2)-      _entrySelector <- getWord16be-      -- (2 * segCount) - searchRange-      _rangeShift <- getWord16be--      let fetcher :: Get (VU.Vector Int)-          fetcher =-            VU.replicateM segCount (fromIntegral <$> getWord16be)--      endCodes <- fetcher-      _reservedPad <- getWord16be-      startCodes <- fetcher-      idDelta <--          VU.replicateM segCount (fromIntegral <$> getWord16be) :: Get (VU.Vector Int16)-      idRangeOffset <- fetcher--      tableBeginIndex <- bytesRead-      let idDeltaInt = VU.map fromIntegral idDelta-          rangeInfo = init . VU.toList $-              VU.zip5 startCodes endCodes idDeltaInt idRangeOffset $-                   VU.enumFromN 0 segCount--          indexLeft = fromIntegral $-              (tableLength - (tableBeginIndex - startIndex + 2))-                  `div` 2--      indexTable <- VU.replicateM indexLeft getWord16be--      endIndex <- bytesRead-      let toSkip = endIndex - startIndex - tableLength + 2-      if toSkip < 0 then-        fail $ "Read to much Format4 table " ++ show toSkip-      else-        skip $ fromIntegral toSkip---      return . Format4 language . M.fromList-             $ concatMap (prepare segCount indexTable) rangeInfo-    where-      prepare _ _ (start, end, delta, 0, _) =-        [(fromIntegral char, fromIntegral $ char + delta)-                    | char <- [start .. end]]-      prepare segCount indexTable-              (start, end, delta, rangeOffset, ix) =-        -- this is... so convoluted oO-        [( fromIntegral char-         , fromIntegral (if glyphId == 0 then 0 else glyphId + fromIntegral delta))-              | char <- [start .. end]-              , let index =-                      (rangeOffset `div` 2) + (char - start) + ix-                            - segCount-              , index < VU.length indexTable-              , let glyphId = indexTable VU.! index-              ]---------------------------------------------------------            Format0----------------------------------------------------data Format0 = Format0-    { _format0Language :: {-# UNPACK #-} !LangId-    , _format0Table    :: !(VU.Vector Word8)-    }-    deriving (Eq, Show)--instance CharMappeable Format0 where-  glyphIdFromTable Format0 { _format0Table = table } v-    | ic > VU.length table = 0-    | otherwise = fromIntegral $ table VU.! ic-        where ic = fromEnum v-        -  langIdOfCharMap = _format0Language--instance Binary Format0 where-    put _ = fail "Binary.Format0.put - unimplemented"-    get = do-        tableSize <- getWord16be-        when (tableSize /= 262) $-            fail ("table cmap format 0, invalid size: "-                    ++ show tableSize)-        Format0 <$> getWord16be <*> VU.replicateM 256 getWord8---------------------------------------------------------            Format2----------------------------------------------------data Format2 = Format2-    { _format2Language   :: {-# UNPACK #-} !LangId-    , _format2SubKeys    :: !(VU.Vector Word16)-    , _format2SubHeaders :: !(V.Vector Format2SubHeader)-    }-    deriving (Eq, Show)--data Format2SubHeader = Format2SubHeader-    { _f2SubCode       :: {-# UNPACK #-} !Word16-    , _f2EntryCount    :: {-# UNPACK #-} !Word16-    , _f2IdDelta       :: {-# UNPACK #-} !Int16-    , _f2IdRangeOffset :: {-# UNPACK #-} !Word16-    }-    deriving (Eq, Show)--instance CharMappeable Format2 where-  glyphIdFromTable _ _ = 0-  langIdOfCharMap = _format2Language--instance Binary Format2SubHeader where-    put (Format2SubHeader a b c d) =-        p16 a >> p16 b >> pi16 c >> p16 d-      where-        p16 = putWord16be-        pi16 = p16 . fromIntegral--    get = Format2SubHeader <$> g16 <*> g16 <*> (fromIntegral <$> g16) <*> g16-      where g16 = getWord16be---instance Binary Format2 where-    put _ = fail "Format2.put - unimplemented"-    get = do-      _tableSize <- getWord16be-      lang <- getWord16be-      subKeys <- VU.map (`div` 8) <$> VU.replicateM 256 getWord16be-      let maxSubIndex = VU.maximum subKeys-      subHeaders <- V.replicateM (fromIntegral maxSubIndex) get-      -- TODO finish the parsing of format 2-      return $ Format2 lang subKeys subHeaders---------------------------------------------------------            Format6----------------------------------------------------data Format6 = Format6-    { _format6Language   :: {-# UNPACK #-} !LangId-    , _format6FirstCode  :: {-# UNPACK #-} !Word16-    , _format6ArrayIndex :: !(VU.Vector Word16)-    }-    deriving (Eq, Show)--instance CharMappeable Format6 where-  glyphIdFromTable Format6 { _format6ArrayIndex = table } v-    | ic < VU.length table = fromIntegral $ table VU.! ic-    | otherwise = 0-      where ic = fromEnum v--  langIdOfCharMap = _format6Language--instance Binary Format6 where-    put _ = fail "Format6.put - unimplemented"-    get = do-        _length <- getWord16be-        language <- getWord16be-        firstCode <- getWord16be-        entryCount <- fromIntegral <$> getWord16be-        Format6 language firstCode <$> VU.replicateM entryCount getWord16be+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP #-}
+module Graphics.Text.TrueType.CharacterMap
+    ( TtfEncoding( .. )
+    , CharacterMaps
+    , LangId
+    , findCharGlyph
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<*>), (<$>) )
+#endif
+
+import Control.DeepSeq( NFData( .. ) )
+import Control.Monad( replicateM,  when, foldM  )
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( Get
+                      , skip
+                      , bytesRead
+                      , getWord8
+                      , getWord16be
+                      , getWord32be )
+
+import Data.Binary.Put( putWord16be
+                      , putWord32be )
+import Data.Int( Int16 )
+import Data.List( find, sort, sortBy )
+import qualified Data.Map.Strict as M
+import Data.Maybe( fromMaybe )
+import Data.Word( Word8, Word16, Word32 )
+import Data.Ord( comparing )
+
+import qualified Data.Vector as V
+import qualified Data.Vector.Unboxed as VU
+
+import Graphics.Text.TrueType.LanguageIds
+
+--------------------------------------------------
+----            TtfEncoding
+--------------------------------------------------
+data TtfEncoding
+  = EncodingSymbol
+  | EncodingUnicode
+  | EncodingShiftJIS
+  | EncodingBig5
+  | EncodingPRC
+  | EncodingWansung
+  | EncodingJohab
+  deriving (Eq, Show)
+
+instance Binary TtfEncoding where
+    put EncodingSymbol = putWord16be 0
+    put EncodingUnicode = putWord16be 1
+    put EncodingShiftJIS = putWord16be 2
+    put EncodingBig5 = putWord16be 3
+    put EncodingPRC = putWord16be 4
+    put EncodingWansung = putWord16be 5
+    put EncodingJohab = putWord16be 6
+
+    get = do
+      v <- getWord16be
+      case v of
+        0 -> return EncodingSymbol
+        1 -> return EncodingUnicode
+        2 -> return EncodingShiftJIS
+        3 -> return EncodingBig5
+        4 -> return EncodingPRC
+        5 -> return EncodingWansung
+        6 -> return EncodingJohab
+        _ -> fail "Unknown encoding"
+
+class CharMappeable a where
+  -- | Given a group a character, return a valid glyph
+  -- id and the rest of the string.
+  glyphIdFromTable :: a -> Char -> Int
+
+  -- | Given a table, retrieve the language code
+  langIdOfCharMap :: a -> LangId
+
+type LangId = Word16
+
+--------------------------------------------------
+----            CharacterMaps
+--------------------------------------------------
+data CharacterMap = CharacterMap
+    { _charMapPlatformId       :: !PlatformId
+    , _charMapPlatformSpecific :: !Word16
+    , _charMap                 :: !CharacterTable
+    }
+    deriving (Eq, Show)
+
+instance NFData CharacterMap where
+  rnf (CharacterMap {}) = ()
+
+instance Ord CharacterMap where
+    compare = comparing _charMap
+
+newtype CharacterMaps = CharacterMaps [CharacterMap]
+    deriving (Eq, Show)
+
+instance NFData CharacterMaps where
+  rnf (CharacterMaps maps) = rnf maps `seq` ()
+
+instance Binary CharacterMaps where
+  put _ = fail "Unimplemented"
+  get = do
+      startIndex <- bytesRead
+      versionNumber <- getWord16be
+      when (versionNumber /= 0)
+           (fail "Characte map - invalid version number")
+      tableCount <- fromIntegral <$> getWord16be
+      let descFetcher = (,,) <$> get <*> getWord16be <*> getWord32be
+          third (_, _, t) = t
+      tableDesc <-
+          sortBy (comparing third) <$> replicateM tableCount descFetcher
+          
+
+      let fetcher (allMaps, lst) (platformId, platformSpecific, offset)
+              | M.member offset allMaps = case M.lookup offset allMaps of
+                  Nothing -> fail "Impossible"
+                  Just table ->
+                      return (allMaps, CharacterMap platformId platformSpecific table : lst)
+          fetcher (allMaps, lst) (platformId, platformSpecific, offset) = do
+              currentOffset <- fromIntegral <$> bytesRead
+              let toSkip = fromIntegral offset - currentOffset + startIndex
+              when (toSkip > 0)
+                  (skip $ fromIntegral toSkip)
+              mapData <- get
+              let charMap = CharacterMap platformId platformSpecific mapData
+              return (M.insert offset mapData allMaps, charMap : lst)
+ 
+      (_, tables) <- foldM fetcher (M.empty, []) tableDesc
+      return . CharacterMaps $ sortBy (comparing _charMap) tables
+
+data CharMapOffset = CharMapOffset
+    { _cmoPlatformId :: !Word16
+    , _cmoEncodingId :: !TtfEncoding
+    , _cmoOffset     :: !Word32
+    }
+    deriving (Eq, Show)
+
+instance Binary CharMapOffset where
+    get = CharMapOffset <$> getWord16be <*> get <*> getWord32be
+    put (CharMapOffset platform encoding offset) =
+      putWord16be platform >> put encoding >> putWord32be offset
+
+--------------------------------------------------
+----            CharacterTable
+--------------------------------------------------
+data CharacterTable
+    = TableFormat0 !Format0
+    | TableFormat2 !Format2
+    | TableFormat4 !Format4
+    | TableFormat6 !Format6
+    | TableFormatUnknown !Word16
+    deriving (Eq, Show)
+
+charTableMap :: (forall table . (CharMappeable table) => table -> a)
+             -> CharacterTable -> a
+charTableMap f = go
+  where
+    go (TableFormat0 t) = f t
+    go (TableFormat2 t) = f t
+    go (TableFormat4 t) = f t
+    go (TableFormat6 t) = f t
+    go (TableFormatUnknown v) = f v
+
+findCharGlyph :: CharacterMaps -> LangId -> Char -> Int
+findCharGlyph (CharacterMaps charMaps) langId character =
+    fromMaybe 0 . find (/= 0) . map snd . sort $
+        [(_charMapPlatformId allMap, charTableMap (`glyphIdFromTable` character) m)
+                | allMap <- charMaps
+                , let m = _charMap allMap
+                , isLangCompatible m]
+  where
+    isLangCompatible v = tableLang == 0 || tableLang == langId 
+      where tableLang = charTableMap langIdOfCharMap v
+
+instance Ord CharacterTable where
+    compare (TableFormat0 v1) (TableFormat0 v2) =
+        comparing langIdOfCharMap v1 v2
+    compare (TableFormat2 v1) (TableFormat2 v2) =
+        comparing langIdOfCharMap v1 v2
+    compare (TableFormat4 v1) (TableFormat4 v2) =
+        comparing langIdOfCharMap v1 v2
+    compare (TableFormat6 v1) (TableFormat6 v2) =
+        comparing langIdOfCharMap v1 v2
+    compare (TableFormat0 _) _ = LT
+    compare (TableFormat2 _) _ = LT
+    compare (TableFormat4 _) _ = LT
+    compare (TableFormat6 _) _ = LT
+    compare _ _ = GT
+
+instance Binary CharacterTable where
+    put _ = fail "Binary.put CharacterTable - Unimplemented"
+    get = do
+      format <- getWord16be
+      case format of
+        0 -> TableFormat0 <$> get
+        2 -> TableFormat2 <$> get
+        4 -> TableFormat4 <$> get
+        6 -> TableFormat6 <$> get
+        n -> return $ TableFormatUnknown n
+
+instance CharMappeable Word16 where
+  glyphIdFromTable _ _ = 0
+  langIdOfCharMap _ = 0
+
+
+--------------------------------------------------
+----            Format4
+--------------------------------------------------
+data Format4 = Format4
+    { _f4Language :: {-# UNPACK #-} !LangId
+    , _f4Map :: M.Map Word16 Word16
+    }
+    deriving (Eq, Show)
+
+instance CharMappeable Format4 where
+  glyphIdFromTable tab v =
+      fromIntegral . M.findWithDefault 0 wc $ _f4Map tab
+        where wc = fromIntegral $ fromEnum v
+  langIdOfCharMap = _f4Language
+
+instance Binary Format4 where
+  put _ = error "put Format4 - unimplemented"
+  get = do
+      startIndex <- bytesRead
+      tableLength <- fromIntegral <$> getWord16be
+      language <- getWord16be
+      -- 2 * segCount
+      segCount <- (`div` 2) . fromIntegral <$> getWord16be
+      -- 2 * (2**FLOOR(log2(segCount)))
+      _searchRange <- getWord16be
+      -- log2(searchRange/2)
+      _entrySelector <- getWord16be
+      -- (2 * segCount) - searchRange
+      _rangeShift <- getWord16be
+
+      let fetcher :: Get (VU.Vector Int)
+          fetcher =
+            VU.replicateM segCount (fromIntegral <$> getWord16be)
+
+      endCodes <- fetcher
+      _reservedPad <- getWord16be
+      startCodes <- fetcher
+      idDelta <-
+          VU.replicateM segCount (fromIntegral <$> getWord16be) :: Get (VU.Vector Int16)
+      idRangeOffset <- fetcher
+
+      tableBeginIndex <- bytesRead
+      let idDeltaInt = VU.map fromIntegral idDelta
+          rangeInfo = init . VU.toList $
+              VU.zip5 startCodes endCodes idDeltaInt idRangeOffset $
+                   VU.enumFromN 0 segCount
+
+          indexLeft = fromIntegral $
+              (tableLength - (tableBeginIndex - startIndex + 2))
+                  `div` 2
+
+      indexTable <- VU.replicateM indexLeft getWord16be
+
+      endIndex <- bytesRead
+      let toSkip = endIndex - startIndex - tableLength + 2
+      if toSkip < 0 then
+        fail $ "Read to much Format4 table " ++ show toSkip
+      else
+        skip $ fromIntegral toSkip
+
+
+      return . Format4 language . M.fromList
+             $ concatMap (prepare segCount indexTable) rangeInfo
+    where
+      prepare _ _ (start, end, delta, 0, _) =
+        [(fromIntegral char, fromIntegral $ char + delta)
+                    | char <- [start .. end]]
+      prepare segCount indexTable
+              (start, end, delta, rangeOffset, ix) =
+        -- this is... so convoluted oO
+        [( fromIntegral char
+         , fromIntegral (if glyphId == 0 then 0 else glyphId + fromIntegral delta))
+              | char <- [start .. end]
+              , let index =
+                      (rangeOffset `div` 2) + (char - start) + ix
+                            - segCount
+              , index < VU.length indexTable
+              , let glyphId = indexTable VU.! index
+              ]
+
+--------------------------------------------------
+----            Format0
+--------------------------------------------------
+data Format0 = Format0
+    { _format0Language :: {-# UNPACK #-} !LangId
+    , _format0Table    :: !(VU.Vector Word8)
+    }
+    deriving (Eq, Show)
+
+instance CharMappeable Format0 where
+  glyphIdFromTable Format0 { _format0Table = table } v
+    | ic > VU.length table = 0
+    | otherwise = fromIntegral $ table VU.! ic
+        where ic = fromEnum v
+        
+  langIdOfCharMap = _format0Language
+
+instance Binary Format0 where
+    put _ = fail "Binary.Format0.put - unimplemented"
+    get = do
+        tableSize <- getWord16be
+        when (tableSize /= 262) $
+            fail ("table cmap format 0, invalid size: "
+                    ++ show tableSize)
+        Format0 <$> getWord16be <*> VU.replicateM 256 getWord8
+
+--------------------------------------------------
+----            Format2
+--------------------------------------------------
+data Format2 = Format2
+    { _format2Language   :: {-# UNPACK #-} !LangId
+    , _format2SubKeys    :: !(VU.Vector Word16)
+    , _format2SubHeaders :: !(V.Vector Format2SubHeader)
+    }
+    deriving (Eq, Show)
+
+data Format2SubHeader = Format2SubHeader
+    { _f2SubCode       :: {-# UNPACK #-} !Word16
+    , _f2EntryCount    :: {-# UNPACK #-} !Word16
+    , _f2IdDelta       :: {-# UNPACK #-} !Int16
+    , _f2IdRangeOffset :: {-# UNPACK #-} !Word16
+    }
+    deriving (Eq, Show)
+
+instance CharMappeable Format2 where
+  glyphIdFromTable _ _ = 0
+  langIdOfCharMap = _format2Language
+
+instance Binary Format2SubHeader where
+    put (Format2SubHeader a b c d) =
+        p16 a >> p16 b >> pi16 c >> p16 d
+      where
+        p16 = putWord16be
+        pi16 = p16 . fromIntegral
+
+    get = Format2SubHeader <$> g16 <*> g16 <*> (fromIntegral <$> g16) <*> g16
+      where g16 = getWord16be
+
+
+instance Binary Format2 where
+    put _ = fail "Format2.put - unimplemented"
+    get = do
+      _tableSize <- getWord16be
+      lang <- getWord16be
+      subKeys <- VU.map (`div` 8) <$> VU.replicateM 256 getWord16be
+      let maxSubIndex = VU.maximum subKeys
+      subHeaders <- V.replicateM (fromIntegral maxSubIndex) get
+      -- TODO finish the parsing of format 2
+      return $ Format2 lang subKeys subHeaders
+
+--------------------------------------------------
+----            Format6
+--------------------------------------------------
+data Format6 = Format6
+    { _format6Language   :: {-# UNPACK #-} !LangId
+    , _format6FirstCode  :: {-# UNPACK #-} !Word16
+    , _format6ArrayIndex :: !(VU.Vector Word16)
+    }
+    deriving (Eq, Show)
+
+instance CharMappeable Format6 where
+  glyphIdFromTable Format6 { _format6ArrayIndex = table } v
+    | ic < VU.length table = fromIntegral $ table VU.! ic
+    | otherwise = 0
+      where ic = fromEnum v
+
+  langIdOfCharMap = _format6Language
+
+instance Binary Format6 where
+    put _ = fail "Format6.put - unimplemented"
+    get = do
+        _length <- getWord16be
+        language <- getWord16be
+        firstCode <- getWord16be
+        entryCount <- fromIntegral <$> getWord16be
+        Format6 language firstCode <$> VU.replicateM entryCount getWord16be

src/Graphics/Text/TrueType/FontFolders.hs view

@@ -1,241 +1,241 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.FontFolders-    ( loadUnixFontFolderList-    , loadWindowsFontFolderList-    , fontFolders-    , findFont-    , descriptorOf-    , FontCache( .. )-    , FontDescriptor( .. )-    , emptyFontCache-    , buildFontCache-    , enumerateFonts-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-#endif--#if !MIN_VERSION_base(4,6,0)-import Control.Monad( guard )-import Control.Exception( tryJust )-import System.IO.Error( isDoesNotExistError )-import System.Environment( getEnv )-#else-import System.Environment( lookupEnv )-#endif--import Control.Monad( when, replicateM )-import System.Directory( getDirectoryContents-                       , getHomeDirectory-                       , doesDirectoryExist-                       , doesFileExist-                       )-import qualified Data.ByteString as B-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( Get-                      , getWord32be-                      , getByteString-                      )-import Data.Binary.Put( Put-                      , putWord32be-                      , putByteString )-import qualified Data.Map.Strict as M-import System.FilePath( (</>) )--import Text.XML.Light( elChildren-                     , elName-                     , onlyElems-                     , parseXML-                     , qName-                     , strContent )--import qualified Control.Exception as E-import qualified Data.Text as T-import qualified Data.Text.IO as T (readFile)--import Graphics.Text.TrueType.FontType-import Graphics.Text.TrueType.Header-import Graphics.Text.TrueType.Name--import Control.DeepSeq (($!!))--catchAny :: IO a -> (E.SomeException -> IO a) -> IO a-catchAny = E.catch--loadParseFontsConf :: IO [FilePath]-loadParseFontsConf = getPaths <$> T.readFile "/etc/fonts/fonts.conf"-  where-    getPaths s = map strContent-                 $ filter ((== "dir") . qName . elName)-                 $ concatMap elChildren-                 $ onlyElems-                 $ parseXML s--#if !MIN_VERSION_base(4,6,0)-lookupEnv :: String -> IO (Maybe String)-lookupEnv varName = do-  v <- tryJust (guard . isDoesNotExistError) $ getEnv varName-  case v of-    Left _ -> return Nothing-    Right val -> return $ Just val-#endif--loadUnixFontFolderList :: IO [FilePath]-loadUnixFontFolderList = catchAny-                         (do conf <- loadParseFontsConf-                             return $!! conf ++ map (</> "truetype") conf)-                         (const $ return defaults)-  where-    defaults = ["/usr/share/fonts", "/usr/local/share/fonts", "~/.fonts"]--loadWindowsFontFolderList :: IO [FilePath]-loadWindowsFontFolderList = toFontFolder <$> lookupEnv "Windir"-  where toFontFolder (Just a) = [a </> "Fonts"]-        toFontFolder Nothing = []--loadOsXFontFolderList :: IO [FilePath]-loadOsXFontFolderList = do-    home <- getHomeDirectory-    return [home </> "Library" </> "Fonts"-           ,"/" </> "Library" </> "Fonts"-           ,"/" </> "System" </> "Library" </> "Fonts"-           ,"/" </> "System Folder" </> "Fonts"-           ]---fontFolders :: IO [FilePath]-fontFolders = do-    unix <- loadUnixFontFolderList-    win <- loadWindowsFontFolderList-    osx <- loadOsXFontFolderList-    return $ unix ++ win ++ osx---- | A font descriptor is a key used to find a font--- in a font cache.-data FontDescriptor = FontDescriptor-    { -- | The family name of the font-      _descriptorFamilyName :: !T.Text-      -- | The desired style-    , _descriptorStyle :: !FontStyle-    }-    deriving (Eq, Ord, Show)--instance Binary FontDescriptor where-  put (FontDescriptor t s) = put (T.unpack t) >> put s-  get = FontDescriptor <$> (T.pack <$> get) <*> get---- | A font cache is a cache listing all the found--- fonts on the system, allowing faster font lookup--- once created------ FontCache is an instance of binary, to get okish--- performance you should save it in a file somewhere--- instead of rebuilding it everytime!------ The font cache is dependent on the version--- of rasterific, you must rebuild it for every--- version.-newtype FontCache =-    FontCache (M.Map FontDescriptor FilePath)-    deriving Show---- | Font cache with no pre-existing fonts in it.-emptyFontCache :: FontCache-emptyFontCache = FontCache M.empty--signature :: B.ByteString-signature = "FontyFruity__FONTCACHE:0.5"--putFontCache :: FontCache -> Put-putFontCache (FontCache cache) = do-  putByteString signature-  putWord32be . fromIntegral $ M.size cache-  mapM_ put $ M.toList cache--getFontCache :: Get FontCache-getFontCache = do-  str <- getByteString $ B.length signature-  when (str /= signature) $-      fail "Invalid font cache"-  count <- fromIntegral <$> getWord32be-  FontCache . M.fromList <$> replicateM count get--instance Binary FontCache where-  put = putFontCache-  get = getFontCache---- | Returns a list of descriptors of fonts stored in the given cache.-enumerateFonts :: FontCache -> [FontDescriptor]-enumerateFonts (FontCache fs) = M.keys fs----- | If possible, returns a descriptor of the Font.-descriptorOf :: Font -> Maybe FontDescriptor-descriptorOf font = do-  hdr <- _fontHeader font-  names <- _fontNames font-  return $ FontDescriptor (fontFamilyName names) (_fHdrMacStyle hdr)----- | Look in the system's folder for usable fonts.-buildFontCache :: (FilePath -> IO (Maybe Font)) -> IO FontCache-buildFontCache loader = do-  folders <- fontFolders-  found <- build [("", v) | v <- folders]-  return . FontCache-         $ M.fromList [(d, path) | (Just d, path) <- found-                                 , _descriptorFamilyName d /= ""]-  where-    build [] = return []-    build ((".", _):rest) = build rest-    build (("..", _):rest) = build rest-    build ((_, n):rest) = do-      isDirectory <- doesDirectoryExist n--      if isDirectory then do-        sub <- getDirectoryContents n-        (++) <$> build [(s, n </> s) | s <- sub]-             <*> build rest-      else do-        isFile <- doesFileExist n-        if isFile then do-            f <- loader n-            case f of-              Nothing -> build rest-              Just fo -> ((descriptorOf fo, n) :) <$> build rest-        else build rest--findFont :: (FilePath -> IO (Maybe Font)) -> String -> FontStyle-         -> IO (Maybe FilePath)-findFont loader fontName fontStyle = do-    folders <- fontFolders-    searchIn [("", v) | v <- folders]-  where-    fontNameText = T.pack fontName-    isMatching n (Font { _fontHeader = Just hdr-                       , _fontNames = Just names})-      | _fHdrMacStyle hdr == fontStyle &&-          fontFamilyName names == fontNameText = Just n-    isMatching _ _ = Nothing--    searchIn [] = return Nothing-    searchIn ((".", _):rest) = searchIn rest-    searchIn (("..", _):rest) = searchIn rest-    searchIn ((_, n):rest) = do-      isDirectory <- doesDirectoryExist n--      let findOrRest Nothing = searchIn rest-          findOrRest l = return l--      if isDirectory then do-        sub <- getDirectoryContents n-        subRez <- searchIn [(s, n </> s) | s <- sub]-        findOrRest subRez-      else do-        isFile <- doesFileExist n-        if isFile then do-          font <- loader n-          findOrRest $ font >>= isMatching n-        else searchIn rest+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
+module Graphics.Text.TrueType.FontFolders
+    ( loadUnixFontFolderList
+    , loadWindowsFontFolderList
+    , fontFolders
+    , findFont
+    , descriptorOf
+    , FontCache( .. )
+    , FontDescriptor( .. )
+    , emptyFontCache
+    , buildFontCache
+    , enumerateFonts
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<*>), (<$>) )
+#endif
+
+#if !MIN_VERSION_base(4,6,0)
+import Control.Monad( guard )
+import Control.Exception( tryJust )
+import System.IO.Error( isDoesNotExistError )
+import System.Environment( getEnv )
+#else
+import System.Environment( lookupEnv )
+#endif
+
+import Control.Monad( when, replicateM )
+import System.Directory( getDirectoryContents
+                       , getHomeDirectory
+                       , doesDirectoryExist
+                       , doesFileExist
+                       )
+import qualified Data.ByteString as B
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( Get
+                      , getWord32be
+                      , getByteString
+                      )
+import Data.Binary.Put( Put
+                      , putWord32be
+                      , putByteString )
+import qualified Data.Map.Strict as M
+import System.FilePath( (</>) )
+
+import Text.XML.Light( elChildren
+                     , elName
+                     , onlyElems
+                     , parseXML
+                     , qName
+                     , strContent )
+
+import qualified Control.Exception as E
+import qualified Data.Text as T
+import qualified Data.Text.IO as T (readFile)
+
+import Graphics.Text.TrueType.FontType
+import Graphics.Text.TrueType.Header
+import Graphics.Text.TrueType.Name
+
+import Control.DeepSeq (($!!))
+
+catchAny :: IO a -> (E.SomeException -> IO a) -> IO a
+catchAny = E.catch
+
+loadParseFontsConf :: IO [FilePath]
+loadParseFontsConf = getPaths <$> T.readFile "/etc/fonts/fonts.conf"
+  where
+    getPaths s = map strContent
+                 $ filter ((== "dir") . qName . elName)
+                 $ concatMap elChildren
+                 $ onlyElems
+                 $ parseXML s
+
+#if !MIN_VERSION_base(4,6,0)
+lookupEnv :: String -> IO (Maybe String)
+lookupEnv varName = do
+  v <- tryJust (guard . isDoesNotExistError) $ getEnv varName
+  case v of
+    Left _ -> return Nothing
+    Right val -> return $ Just val
+#endif
+
+loadUnixFontFolderList :: IO [FilePath]
+loadUnixFontFolderList = catchAny
+                         (do conf <- loadParseFontsConf
+                             return $!! conf ++ map (</> "truetype") conf)
+                         (const $ return defaults)
+  where
+    defaults = ["/usr/share/fonts", "/usr/local/share/fonts", "~/.fonts"]
+
+loadWindowsFontFolderList :: IO [FilePath]
+loadWindowsFontFolderList = toFontFolder <$> lookupEnv "Windir"
+  where toFontFolder (Just a) = [a </> "Fonts"]
+        toFontFolder Nothing = []
+
+loadOsXFontFolderList :: IO [FilePath]
+loadOsXFontFolderList = do
+    home <- getHomeDirectory
+    return [home </> "Library" </> "Fonts"
+           ,"/" </> "Library" </> "Fonts"
+           ,"/" </> "System" </> "Library" </> "Fonts"
+           ,"/" </> "System Folder" </> "Fonts"
+           ]
+
+
+fontFolders :: IO [FilePath]
+fontFolders = do
+    unix <- loadUnixFontFolderList
+    win <- loadWindowsFontFolderList
+    osx <- loadOsXFontFolderList
+    return $ unix ++ win ++ osx
+
+-- | A font descriptor is a key used to find a font
+-- in a font cache.
+data FontDescriptor = FontDescriptor
+    { -- | The family name of the font
+      _descriptorFamilyName :: !T.Text
+      -- | The desired style
+    , _descriptorStyle :: !FontStyle
+    }
+    deriving (Eq, Ord, Show)
+
+instance Binary FontDescriptor where
+  put (FontDescriptor t s) = put (T.unpack t) >> put s
+  get = FontDescriptor <$> (T.pack <$> get) <*> get
+
+-- | A font cache is a cache listing all the found
+-- fonts on the system, allowing faster font lookup
+-- once created
+--
+-- FontCache is an instance of binary, to get okish
+-- performance you should save it in a file somewhere
+-- instead of rebuilding it everytime!
+--
+-- The font cache is dependent on the version
+-- of rasterific, you must rebuild it for every
+-- version.
+newtype FontCache =
+    FontCache (M.Map FontDescriptor FilePath)
+    deriving Show
+
+-- | Font cache with no pre-existing fonts in it.
+emptyFontCache :: FontCache
+emptyFontCache = FontCache M.empty
+
+signature :: B.ByteString
+signature = "FontyFruity__FONTCACHE:0.5"
+
+putFontCache :: FontCache -> Put
+putFontCache (FontCache cache) = do
+  putByteString signature
+  putWord32be . fromIntegral $ M.size cache
+  mapM_ put $ M.toList cache
+
+getFontCache :: Get FontCache
+getFontCache = do
+  str <- getByteString $ B.length signature
+  when (str /= signature) $
+      fail "Invalid font cache"
+  count <- fromIntegral <$> getWord32be
+  FontCache . M.fromList <$> replicateM count get
+
+instance Binary FontCache where
+  put = putFontCache
+  get = getFontCache
+
+-- | Returns a list of descriptors of fonts stored in the given cache.
+enumerateFonts :: FontCache -> [FontDescriptor]
+enumerateFonts (FontCache fs) = M.keys fs
+
+
+-- | If possible, returns a descriptor of the Font.
+descriptorOf :: Font -> Maybe FontDescriptor
+descriptorOf font = do
+  hdr <- _fontHeader font
+  names <- _fontNames font
+  return $ FontDescriptor (fontFamilyName names) (_fHdrMacStyle hdr)
+
+
+-- | Look in the system's folder for usable fonts.
+buildFontCache :: (FilePath -> IO (Maybe Font)) -> IO FontCache
+buildFontCache loader = do
+  folders <- fontFolders
+  found <- build [("", v) | v <- folders]
+  return . FontCache
+         $ M.fromList [(d, path) | (Just d, path) <- found
+                                 , _descriptorFamilyName d /= ""]
+  where
+    build [] = return []
+    build ((".", _):rest) = build rest
+    build (("..", _):rest) = build rest
+    build ((_, n):rest) = do
+      isDirectory <- doesDirectoryExist n
+
+      if isDirectory then do
+        sub <- getDirectoryContents n
+        (++) <$> build [(s, n </> s) | s <- sub]
+             <*> build rest
+      else do
+        isFile <- doesFileExist n
+        if isFile then do
+            f <- loader n
+            case f of
+              Nothing -> build rest
+              Just fo -> ((descriptorOf fo, n) :) <$> build rest
+        else build rest
+
+findFont :: (FilePath -> IO (Maybe Font)) -> String -> FontStyle
+         -> IO (Maybe FilePath)
+findFont loader fontName fontStyle = do
+    folders <- fontFolders
+    searchIn [("", v) | v <- folders]
+  where
+    fontNameText = T.pack fontName
+    isMatching n (Font { _fontHeader = Just hdr
+                       , _fontNames = Just names})
+      | _fHdrMacStyle hdr == fontStyle &&
+          fontFamilyName names == fontNameText = Just n
+    isMatching _ _ = Nothing
+
+    searchIn [] = return Nothing
+    searchIn ((".", _):rest) = searchIn rest
+    searchIn (("..", _):rest) = searchIn rest
+    searchIn ((_, n):rest) = do
+      isDirectory <- doesDirectoryExist n
+
+      let findOrRest Nothing = searchIn rest
+          findOrRest l = return l
+
+      if isDirectory then do
+        sub <- getDirectoryContents n
+        subRez <- searchIn [(s, n </> s) | s <- sub]
+        findOrRest subRez
+      else do
+        isFile <- doesFileExist n
+        if isFile then do
+          font <- loader n
+          findOrRest $ font >>= isMatching n
+        else searchIn rest

src/Graphics/Text/TrueType/Glyph.hs view

@@ -1,331 +1,322 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.Glyph-    ( GlyphHeader( .. )-    , GlyphContour( .. )-    , CompositeScaling( .. )-    , GlyphComposition( .. )-    , GlyphContent( .. )-    , Glyph( .. )-    , GlyphFlag( .. )-    , extractFlatOutline-    , emptyGlyph-    ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( mempty )-import Control.Applicative( (<*>), (<$>) )-#endif--import Control.DeepSeq-import Data.Bits( setBit, testBit, shiftL )-import Data.Int( Int16 )-import Data.List( mapAccumL, mapAccumR, zip4 )-import Data.Word( Word8, Word16 )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( Get-                      , getWord8-                      , getWord16be )--import Data.Binary.Put( putWord8, putWord16be )-import Data.Tuple( swap )--import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as VU--{-import Text.Printf-}-{-import Debug.Trace-}--data GlyphHeader = GlyphHeader-    { -- | If the number of contours is greater than or equal-      -- to zero, this is a single glyph; if negative, this is-      -- a composite glyph.-      _glfNumberOfContours :: {-# UNPACK #-} !Int16-      -- | Minimum x for coordinate data.-    , _glfXMin             :: {-# UNPACK #-} !Int16-      -- | Minimum y for coordinate data.-    , _glfYMin             :: {-# UNPACK #-} !Int16-      -- | Maximum x for coordinate data.-    , _glfXMax             :: {-# UNPACK #-} !Int16-      -- | Maximum y for coordinate data.-    , _glfYMax             :: {-# UNPACK #-} !Int16-    }-    deriving (Eq, Show)--instance NFData GlyphHeader where-  rnf (GlyphHeader {}) = ()--emptyGlyphHeader :: GlyphHeader-emptyGlyphHeader = GlyphHeader 0 0 0 0 0--instance Binary GlyphHeader where-    get = GlyphHeader <$> g16 <*> g16 <*> g16 <*> g16 <*> g16-      where g16 = fromIntegral <$> getWord16be--    put (GlyphHeader count xmini ymini xmaxi ymaxi) =-        p16 count >> p16 xmini >> p16 ymini >> p16 xmaxi >> p16 ymaxi-      where p16 = putWord16be . fromIntegral--data GlyphContour = GlyphContour-    { _glyphInstructions :: !(VU.Vector Word8)-    , _glyphFlags        :: ![GlyphFlag]-    , _glyphPoints       :: ![VU.Vector (Int16, Int16)]-    }-    deriving (Eq, Show)--instance NFData GlyphContour where-    rnf (GlyphContour instr fl points) =-        instr `seq` fl `seq` points `seq` ()---- | Transformation matrix used to transform composite--- glyph------ @---   | a b c |---   | d e f |--- @----data CompositeScaling = CompositeScaling-    { _a :: {-# UNPACK #-} !Int16 -- ^ a coeff.-    , _b :: {-# UNPACK #-} !Int16 -- ^ b coeff.-    , _c :: {-# UNPACK #-} !Int16 -- ^ c coeff.-    , _d :: {-# UNPACK #-} !Int16 -- ^ d coeff.-    , _e :: {-# UNPACK #-} !Int16 -- ^ e coeff.-    , _f :: {-# UNPACK #-} !Int16 -- ^ f coeff.-    }-    deriving (Eq, Show)--data GlyphComposition = GlyphComposition-    { _glyphCompositeFlag    :: {-# UNPACK #-} !Word16-    , _glyphCompositeIndex   :: {-# UNPACK #-} !Word16-    , _glyphCompositionArg   :: {-# UNPACK #-} !(Int16, Int16)-    , _glyphCompositionScale :: !CompositeScaling-    }-    deriving (Eq, Show)--data GlyphContent-    = GlyphEmpty-    | GlyphSimple    !GlyphContour-    | GlyphComposite !(V.Vector GlyphComposition) !(VU.Vector Word8)-    deriving (Eq, Show)--data Glyph = Glyph-    { _glyphHeader  :: !GlyphHeader-    , _glyphContent :: !GlyphContent-    }-    deriving (Eq, Show)--instance NFData Glyph where-  rnf (Glyph hdr cont) =-      rnf hdr `seq` cont `seq` ()--emptyGlyph :: Glyph-emptyGlyph = Glyph emptyGlyphHeader GlyphEmpty--getCompositeOutline :: Get GlyphContent-getCompositeOutline =-    (\(instr, vals) -> GlyphComposite (V.fromList vals) instr) <$> go-  where-    go = do-      flag <- getWord16be-      index <- getWord16be-      args <- fetchArguments flag-      scaling <- fetchScaling flag-      let fullScaling = fetchOffset scaling args flag-          value = GlyphComposition flag index args fullScaling--      if flag `testBit` mORE_COMPONENTS then-          (\(instr, acc) -> (instr, value : acc )) <$> go-      else-        if flag `testBit` wE_HAVE_INSTRUCTIONS then do-            count <- fromIntegral <$> getWord16be-            (, [value]) <$> VU.replicateM count getWord8-        else-            return (mempty, [value])---    fetchArguments flag-        | flag `testBit` aRG_1_AND_2_ARE_WORDS =-            (,) <$> getInt16be <*> getInt16be-        | otherwise =-            (,) <$> getInt8 <*> getInt8--    fetchScaling flag-        | flag `testBit` wE_HAVE_A_SCALE =-            (\v -> CompositeScaling v 0 0 v) <$> getF2Dot14-        | flag `testBit` wE_HAVE_AN_X_AND_Y_SCALE =-            (\x y -> CompositeScaling x 0 0 y) <$> getF2Dot14 <*> getF2Dot14-        | flag `testBit` wE_HAVE_A_TWO_BY_TWO =-            CompositeScaling <$> getF2Dot14 <*> getF2Dot14-                             <*> getF2Dot14 <*> getF2Dot14-        | otherwise = return $ CompositeScaling one 0 0 one-           where one = 1 `shiftL` 14--    fetchOffset scaling (a1, a2) flag-        | flag `testBit` aRGS_ARE_XY_VALUES = scaling a1 a2-        | otherwise = scaling 0 0 -- TODO fix this crap--    {---    if (!ARGS_ARE_XY_VALUES)-        1st short contains the index of matching point in compound being constructed-        2nd short contains index of matching point in component -}--    getInt16be = fromIntegral <$> getWord16be-    getF2Dot14 = fromIntegral <$> getWord16be-    getInt8 = fixByteSign . fromIntegral <$> getWord8--    fixByteSign value = if value >= 0x80 then value - 0x100 else value--    aRG_1_AND_2_ARE_WORDS  = 0-    aRGS_ARE_XY_VALUES  = 1-    {-rOUND_XY_TO_GRID  = 2-}-    wE_HAVE_A_SCALE  = 3-    {-rESERVED  = 4-}-    mORE_COMPONENTS  = 5-    wE_HAVE_AN_X_AND_Y_SCALE  = 6-    wE_HAVE_A_TWO_BY_TWO  = 7-    wE_HAVE_INSTRUCTIONS  = 8-    {-uSE_MY_METRICS  = 9-}-    {-oVERLAP_COMPOUND  = 10-}-    {-sCALED_COMPONENT_OFFSET  = 11-}-    {-uNSCALED_COMPONENT_OFFSET = 12-}--data GlyphFlag = GlyphFlag-    { -- | If set, the point is on the curve;-      -- otherwise, it is off the curve.-      _flagOnCurve :: !Bool-      -- | If set, the corresponding x-coordinate is 1-      -- byte long. If not set, 2 bytes.-    , _flagXshort  :: !Bool-      -- | If set, the corresponding y-coordinate is 1-      -- byte long. If not set, 2 bytes.-    , _flagYShort  :: !Bool-      -- | If set, the next byte specifies the number of additional-      -- times this set of flags is to be repeated. In this way, the-      -- number of flags listed can be smaller than the number of-      -- points in a character.-    , _flagRepeat  :: !Bool-      -- | This flag has two meanings, depending on how the x-Short-      -- Vector flag is set. If x-Short Vector is set, this bit-      -- describes the sign of the value, with 1 equalling positive and-      -- 0 negative. If the x-Short Vector bit is not set and this bit is set,-      -- then the current x-coordinate is the same as the previous x-coordinate.-      -- If the x-Short Vector bit is not set and this bit is also not set, the-      -- current x-coordinate is a signed 16-bit delta vector.-    , _flagXSame   :: !Bool-      -- | This flag has two meanings, depending on how the y-Short Vector flag-      -- is set. If y-Short Vector is set, this bit describes the sign of the-      -- value, with 1 equalling positive and 0 negative. If the y-Short Vector-      -- bit is not set and this bit is set, then the current y-coordinate is the-      -- same as the previous y-coordinate. If the y-Short Vector bit is not set-      -- and this bit is also not set, the current y-coordinate is a signed-      -- 16-bit delta vector.-    , _flagYSame   :: !Bool-    }-    deriving (Eq, Show)--instance Binary GlyphFlag where-    put (GlyphFlag a0 a1 a2 a3 a4 a5) =-        putWord8 . foldl setter 0 $ zip [0..] [a0, a1, a2, a3, a4, a5]-      where setter v ( _, False) = v-            setter v (ix, True) = setBit v ix-    get = do-      tester <- testBit <$> getWord8-      return GlyphFlag-        { _flagOnCurve = tester 0-        , _flagXshort  = tester 1-        , _flagYShort  = tester 2-        , _flagRepeat  = tester 3-        , _flagXSame   = tester 4-        , _flagYSame   = tester 5-        }--getGlyphFlags :: Int -> Get [GlyphFlag]-getGlyphFlags count = go 0-  where-    go n | n >= count = return []-    go n = do-      flag <- get-      if _flagRepeat flag-        then do-          repeatCount <- fromIntegral <$> getWord8-          let real = min (count - n) (repeatCount + 1)-          (replicate real flag ++) <$> go (n + real)-        else (flag :) <$> go (n + 1)--getCoords :: [GlyphFlag] -> Get (VU.Vector (Int16, Int16))-getCoords flags =-    VU.fromList <$> (zip <$> go (_flagXSame, _flagXshort) 0 flags-                         <*> go (_flagYSame, _flagYShort) 0 flags)-  where-    go _ _ [] = return []-    go axx@(isSame, isShort) prevCoord (flag:flagRest) = do-        let fetcher-              | isShort flag && isSame flag =-                  (prevCoord +) . fromIntegral <$> getWord8-              | isShort flag = -                  (prevCoord - ) . fromIntegral <$> getWord8-              | isSame flag =-                  return prevCoord-              | otherwise =-                  (prevCoord +) . fromIntegral <$> getWord16be--        newCoord <- fetcher-        (newCoord :) <$> go axx newCoord flagRest--extractFlatOutline :: GlyphContour-                   -> [VU.Vector (Int16, Int16)]-extractFlatOutline contour = zipWith (curry go) flagGroup coords-  where-    allFlags = _glyphFlags contour-    coords = _glyphPoints contour-    (_, flagGroup) =-      mapAccumL (\acc v -> swap $ splitAt (VU.length v) acc) allFlags coords--    go (flags, coord) -      | VU.null coord = mempty-      | otherwise = VU.fromList . (firstPoint :) $ expand mixed-      where-       isOnSide = map _flagOnCurve flags-       firstOnCurve = head isOnSide-       lst@(firstPoint:xs) = VU.toList coord-       mixed = zip4 isOnSide (tail isOnSide) lst xs-       midPoint (x1, y1) (x2, y2) =-           ((x1 + x2) `div` 2, (y1 + y2) `div` 2)--       expand [] = []-       expand [(onp, on, prevPoint, currPoint)]-        | onp == on = (prevPoint `midPoint` currPoint) : endJunction-        | otherwise = endJunction-         where endJunction -                | on && firstOnCurve =-                    [currPoint, currPoint `midPoint` firstPoint, firstPoint]-                | otherwise = [currPoint, firstPoint]-       expand ((onp, on, prevPoint, currPoint):rest)-        | onp == on = prevPoint `midPoint` currPoint : currPoint : expand rest-        | otherwise = currPoint : expand rest--getSimpleOutline :: Int16 -> Get GlyphContent-getSimpleOutline counterCount = do-    endOfPoints <- VU.replicateM (fromIntegral counterCount) getWord16be-    let pointCount = VU.last endOfPoints + 1-    instructionCount <- fromIntegral <$> getWord16be-    instructions <- VU.replicateM instructionCount getWord8--    flags <- getGlyphFlags $ fromIntegral pointCount-    GlyphSimple . GlyphContour instructions flags-                . breakOutline endOfPoints <$> getCoords flags-  where-    prepender (v, lst) = v : lst-    breakOutline endPoints coords =-        prepender . mapAccumR breaker coords . VU.toList $ VU.init endPoints-          where breaker array ix = VU.splitAt (fromIntegral ix + 1) array--instance Binary Glyph where-    put _ = fail "Glyph.put - unimplemented"-    get = do-      hdr <- get-      case _glfNumberOfContours hdr of-        -1 -> Glyph hdr <$> getCompositeOutline-        n -> Glyph hdr <$> getSimpleOutline n-+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+module Graphics.Text.TrueType.Glyph
+    ( GlyphHeader( .. )
+    , GlyphContour( .. )
+    , CompositeScaling( .. )
+    , GlyphComposition( .. )
+    , GlyphContent( .. )
+    , Glyph( .. )
+    , GlyphFlag( .. )
+    , extractFlatOutline
+    , emptyGlyph
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid( mempty )
+import Control.Applicative( (<*>), (<$>) )
+#endif
+
+import Control.DeepSeq
+import Data.Bits( setBit, testBit, shiftL )
+import Data.Int( Int16 )
+import Data.List( mapAccumL, mapAccumR, zip4 )
+import Data.Word( Word8, Word16 )
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( Get
+                      , getWord8
+                      , getWord16be )
+
+import Data.Binary.Put( putWord8, putWord16be )
+import Data.Tuple( swap )
+
+import qualified Data.Vector as V
+import qualified Data.Vector.Unboxed as VU
+
+{-import Text.Printf-}
+{-import Debug.Trace-}
+
+data GlyphHeader = GlyphHeader
+    { -- | If the number of contours is greater than or equal
+      -- to zero, this is a single glyph; if negative, this is
+      -- a composite glyph.
+      _glfNumberOfContours :: {-# UNPACK #-} !Int16
+      -- | Minimum x for coordinate data.
+    , _glfXMin             :: {-# UNPACK #-} !Int16
+      -- | Minimum y for coordinate data.
+    , _glfYMin             :: {-# UNPACK #-} !Int16
+      -- | Maximum x for coordinate data.
+    , _glfXMax             :: {-# UNPACK #-} !Int16
+      -- | Maximum y for coordinate data.
+    , _glfYMax             :: {-# UNPACK #-} !Int16
+    }
+    deriving (Eq, Show)
+
+instance NFData GlyphHeader where
+  rnf (GlyphHeader {}) = ()
+
+emptyGlyphHeader :: GlyphHeader
+emptyGlyphHeader = GlyphHeader 0 0 0 0 0
+
+instance Binary GlyphHeader where
+    get = GlyphHeader <$> g16 <*> g16 <*> g16 <*> g16 <*> g16
+      where g16 = fromIntegral <$> getWord16be
+
+    put (GlyphHeader count xmini ymini xmaxi ymaxi) =
+        p16 count >> p16 xmini >> p16 ymini >> p16 xmaxi >> p16 ymaxi
+      where p16 = putWord16be . fromIntegral
+
+data GlyphContour = GlyphContour
+    { _glyphInstructions :: !(VU.Vector Word8)
+    , _glyphFlags        :: ![GlyphFlag]
+    , _glyphPoints       :: ![VU.Vector (Int16, Int16)]
+    }
+    deriving (Eq, Show)
+
+instance NFData GlyphContour where
+    rnf (GlyphContour instr fl points) =
+        instr `seq` fl `seq` points `seq` ()
+
+-- | Transformation matrix used to transform composite
+-- glyph
+--
+-- @
+--   | a b |
+--   | c d |
+-- @
+--
+data CompositeScaling = CompositeScaling
+    { _a :: {-# UNPACK #-} !Int16 -- ^ a coeff.
+    , _b :: {-# UNPACK #-} !Int16 -- ^ b coeff.
+    , _c :: {-# UNPACK #-} !Int16 -- ^ c coeff.
+    , _d :: {-# UNPACK #-} !Int16 -- ^ d coeff.
+    }
+    deriving (Eq, Show)
+
+data GlyphComposition = GlyphComposition
+    { _glyphCompositeFlag         :: {-# UNPACK #-} !Word16
+    , _glyphCompositeIndex        :: {-# UNPACK #-} !Word16
+    , _glyphCompositionArg        :: {-# UNPACK #-} !(Int16, Int16)
+    , _glyphCompositionOffsetArgs :: !Bool -- ^ True: args are offsets;
+                                           --   False: args are point indices
+    , _glyphCompositionScale      :: !CompositeScaling
+    }
+    deriving (Eq, Show)
+
+data GlyphContent
+    = GlyphEmpty
+    | GlyphSimple    !GlyphContour
+    | GlyphComposite !(V.Vector GlyphComposition) !(VU.Vector Word8)
+    deriving (Eq, Show)
+
+data Glyph = Glyph
+    { _glyphHeader  :: !GlyphHeader
+    , _glyphContent :: !GlyphContent
+    }
+    deriving (Eq, Show)
+
+instance NFData Glyph where
+  rnf (Glyph hdr cont) =
+      rnf hdr `seq` cont `seq` ()
+
+emptyGlyph :: Glyph
+emptyGlyph = Glyph emptyGlyphHeader GlyphEmpty
+
+getCompositeOutline :: Get GlyphContent
+getCompositeOutline =
+    (\(instr, vals) -> GlyphComposite (V.fromList vals) instr) <$> go
+  where
+    go = do
+      flag <- getWord16be
+      index <- getWord16be
+      args <- fetchArguments flag
+      scaling <- fetchScaling flag
+      let value = GlyphComposition flag index args
+                     (flag `testBit` aRGS_ARE_XY_VALUES) scaling
+
+      if flag `testBit` mORE_COMPONENTS then
+          (\(instr, acc) -> (instr, value : acc )) <$> go
+      else
+        if flag `testBit` wE_HAVE_INSTRUCTIONS then do
+            count <- fromIntegral <$> getWord16be
+            (, [value]) <$> VU.replicateM count getWord8
+        else
+            return (mempty, [value])
+
+
+    fetchArguments flag
+        | flag `testBit` aRG_1_AND_2_ARE_WORDS =
+            (,) <$> getInt16be <*> getInt16be
+        | otherwise =
+            (,) <$> getInt8 <*> getInt8
+
+    fetchScaling flag
+        | flag `testBit` wE_HAVE_A_SCALE =
+            (\v -> CompositeScaling v 0 0 v) <$> getF2Dot14
+        | flag `testBit` wE_HAVE_AN_X_AND_Y_SCALE =
+            (\x y -> CompositeScaling x 0 0 y) <$> getF2Dot14 <*> getF2Dot14
+        | flag `testBit` wE_HAVE_A_TWO_BY_TWO =
+            CompositeScaling <$> getF2Dot14 <*> getF2Dot14
+                             <*> getF2Dot14 <*> getF2Dot14
+        | otherwise = return $ CompositeScaling one 0 0 one
+           where one = 1 `shiftL` 14
+
+    getInt16be = fromIntegral <$> getWord16be
+    getF2Dot14 = fromIntegral <$> getWord16be
+    getInt8 = fixByteSign . fromIntegral <$> getWord8
+
+    fixByteSign value = if value >= 0x80 then value - 0x100 else value
+
+    aRG_1_AND_2_ARE_WORDS  = 0
+    aRGS_ARE_XY_VALUES  = 1
+    {-rOUND_XY_TO_GRID  = 2-}
+    wE_HAVE_A_SCALE  = 3
+    {-rESERVED  = 4-}
+    mORE_COMPONENTS  = 5
+    wE_HAVE_AN_X_AND_Y_SCALE  = 6
+    wE_HAVE_A_TWO_BY_TWO  = 7
+    wE_HAVE_INSTRUCTIONS  = 8
+    {-uSE_MY_METRICS  = 9-}
+    {-oVERLAP_COMPOUND  = 10-}
+    {-sCALED_COMPONENT_OFFSET  = 11-}
+    {-uNSCALED_COMPONENT_OFFSET = 12-}
+
+data GlyphFlag = GlyphFlag
+    { -- | If set, the point is on the curve;
+      -- otherwise, it is off the curve.
+      _flagOnCurve :: !Bool
+      -- | If set, the corresponding x-coordinate is 1
+      -- byte long. If not set, 2 bytes.
+    , _flagXshort  :: !Bool
+      -- | If set, the corresponding y-coordinate is 1
+      -- byte long. If not set, 2 bytes.
+    , _flagYShort  :: !Bool
+      -- | If set, the next byte specifies the number of additional
+      -- times this set of flags is to be repeated. In this way, the
+      -- number of flags listed can be smaller than the number of
+      -- points in a character.
+    , _flagRepeat  :: !Bool
+      -- | This flag has two meanings, depending on how the x-Short
+      -- Vector flag is set. If x-Short Vector is set, this bit
+      -- describes the sign of the value, with 1 equalling positive and
+      -- 0 negative. If the x-Short Vector bit is not set and this bit is set,
+      -- then the current x-coordinate is the same as the previous x-coordinate.
+      -- If the x-Short Vector bit is not set and this bit is also not set, the
+      -- current x-coordinate is a signed 16-bit delta vector.
+    , _flagXSame   :: !Bool
+      -- | This flag has two meanings, depending on how the y-Short Vector flag
+      -- is set. If y-Short Vector is set, this bit describes the sign of the
+      -- value, with 1 equalling positive and 0 negative. If the y-Short Vector
+      -- bit is not set and this bit is set, then the current y-coordinate is the
+      -- same as the previous y-coordinate. If the y-Short Vector bit is not set
+      -- and this bit is also not set, the current y-coordinate is a signed
+      -- 16-bit delta vector.
+    , _flagYSame   :: !Bool
+    }
+    deriving (Eq, Show)
+
+instance Binary GlyphFlag where
+    put (GlyphFlag a0 a1 a2 a3 a4 a5) =
+        putWord8 . foldl setter 0 $ zip [0..] [a0, a1, a2, a3, a4, a5]
+      where setter v ( _, False) = v
+            setter v (ix, True) = setBit v ix
+    get = do
+      tester <- testBit <$> getWord8
+      return GlyphFlag
+        { _flagOnCurve = tester 0
+        , _flagXshort  = tester 1
+        , _flagYShort  = tester 2
+        , _flagRepeat  = tester 3
+        , _flagXSame   = tester 4
+        , _flagYSame   = tester 5
+        }
+
+getGlyphFlags :: Int -> Get [GlyphFlag]
+getGlyphFlags count = go 0
+  where
+    go n | n >= count = return []
+    go n = do
+      flag <- get
+      if _flagRepeat flag
+        then do
+          repeatCount <- fromIntegral <$> getWord8
+          let real = min (count - n) (repeatCount + 1)
+          (replicate real flag ++) <$> go (n + real)
+        else (flag :) <$> go (n + 1)
+
+getCoords :: [GlyphFlag] -> Get (VU.Vector (Int16, Int16))
+getCoords flags =
+    VU.fromList <$> (zip <$> go (_flagXSame, _flagXshort) 0 flags
+                         <*> go (_flagYSame, _flagYShort) 0 flags)
+  where
+    go _ _ [] = return []
+    go axx@(isSame, isShort) prevCoord (flag:flagRest) = do
+        let fetcher
+              | isShort flag && isSame flag =
+                  (prevCoord +) . fromIntegral <$> getWord8
+              | isShort flag = 
+                  (prevCoord - ) . fromIntegral <$> getWord8
+              | isSame flag =
+                  return prevCoord
+              | otherwise =
+                  (prevCoord +) . fromIntegral <$> getWord16be
+
+        newCoord <- fetcher
+        (newCoord :) <$> go axx newCoord flagRest
+
+extractFlatOutline :: GlyphContour
+                   -> [VU.Vector (Int16, Int16)]
+extractFlatOutline contour = zipWith (curry go) flagGroup coords
+  where
+    allFlags = _glyphFlags contour
+    coords = _glyphPoints contour
+    (_, flagGroup) =
+      mapAccumL (\acc v -> swap $ splitAt (VU.length v) acc) allFlags coords
+
+    go (flags, coord) 
+      | VU.null coord = mempty
+      | otherwise = VU.fromList . (firstPoint :) $ expand mixed
+      where
+       isOnSide = map _flagOnCurve flags
+       firstOnCurve = head isOnSide
+       lst@(firstPoint:xs) = VU.toList coord
+       mixed = zip4 isOnSide (tail isOnSide) lst xs
+       midPoint (x1, y1) (x2, y2) =
+           ((x1 + x2) `div` 2, (y1 + y2) `div` 2)
+
+       expand [] = []
+       expand [(onp, on, prevPoint, currPoint)]
+        | onp == on = (prevPoint `midPoint` currPoint) : endJunction
+        | otherwise = endJunction
+         where endJunction 
+                | on && firstOnCurve =
+                    [currPoint, currPoint `midPoint` firstPoint, firstPoint]
+                | otherwise = [currPoint, firstPoint]
+       expand ((onp, on, prevPoint, currPoint):rest)
+        | onp == on = prevPoint `midPoint` currPoint : currPoint : expand rest
+        | otherwise = currPoint : expand rest
+
+getSimpleOutline :: Int16 -> Get GlyphContent
+getSimpleOutline counterCount = do
+    endOfPoints <- VU.replicateM (fromIntegral counterCount) getWord16be
+    let pointCount = VU.last endOfPoints + 1
+    instructionCount <- fromIntegral <$> getWord16be
+    instructions <- VU.replicateM instructionCount getWord8
+
+    flags <- getGlyphFlags $ fromIntegral pointCount
+    GlyphSimple . GlyphContour instructions flags
+                . breakOutline endOfPoints <$> getCoords flags
+  where
+    prepender (v, lst) = v : lst
+    breakOutline endPoints coords =
+        prepender . mapAccumR breaker coords . VU.toList $ VU.init endPoints
+          where breaker array ix = VU.splitAt (fromIntegral ix + 1) array
+
+instance Binary Glyph where
+    put _ = fail "Glyph.put - unimplemented"
+    get = do
+      hdr <- get
+      case _glfNumberOfContours hdr of
+        -1 -> Glyph hdr <$> getCompositeOutline
+        n -> Glyph hdr <$> getSimpleOutline n
+

src/Graphics/Text/TrueType/Header.hs view

@@ -1,143 +1,143 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.Header-    ( FontHeader( .. )-    , FontStyle( .. )-    , HeaderFlags( .. )-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-#endif--import Control.DeepSeq( NFData( .. ) )-import Data.Bits( (.|.), setBit, testBit )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( getWord16be-                      , getWord32be-                      , getWord64be-                      )--import Data.Binary.Put( putWord16be)--import Data.Int( Int16 )-import Data.List( foldl' )-import Data.Word( Word16, Word32, Word64 )--import Graphics.Text.TrueType.Types---- | Describe the basic stylistic properties--- of a font.-data FontStyle = FontStyle-  { _fontStyleBold   :: !Bool -- ^ If the font is bold.-  , _fontStyleItalic :: !Bool -- ^ If the font is italic.-  }-  deriving (Eq, Ord, Show)--instance Binary FontStyle where-  put style = putWord16be $ italicByte .|. boldByte-    where-      boldByte-        | _fontStyleBold style = 1-        | otherwise = 0--      italicByte-        | _fontStyleItalic style = 2-        | otherwise = 0--  get = do-    styleWord <- getWord16be -    let bitAt = testBit styleWord-    return $ FontStyle (bitAt 0) (bitAt 1)---- | Font header-data FontHeader = FontHeader-    { -- | Table version number	0x00010000 for version 1.0.-      _fHdrVersionNumber    :: !Fixed-      -- | fontRevision	Set by font manufacturer.-    , _fHdrFontRevision     :: !Fixed-      -- | To compute:  set it to 0, sum the entire font as-      -- ULONG, then store 0xB1B0AFBA - sum.-    , _fHdrChecksumAdjust   :: !Word32-     -      -- | Should be equal to 0x5F0F3CF5.-    , _fHdrMagicNumber      :: !Word32-    , _fHdrFlags            :: !HeaderFlags--      -- | Valid range is from 16 to 16384-    , _fUnitsPerEm          :: !Word16-      -- | International date (8-byte field).-    , _fHdrCreateTime       :: !Word64-      -- | International date (8-byte field).-    , _fHdrModificationTime :: !Word64--      -- | For all glyph bounding boxes.-    , _fHdrxMin             :: !FWord-      -- | For all glyph bounding boxes.-    , _fHdrYMin             :: !FWord-      -- | For all glyph bounding boxes.-    , _fHdrXMax             :: !FWord-      -- | For all glyph bounding boxes.-    , _fHdrYMax             :: !FWord-      -- | Bit 0 bold (if set to 1); Bit 1 italic (if set to 1)-    , _fHdrMacStyle         :: !FontStyle-      -- | Smallest readable size in pixels.-    , _fHdrLowestRecPPEM    :: !Word16--      -- | 0   Fully mixed directional glyphs;-      --  1   Only strongly left to right;-      --  2   Like 1 but also contains neutrals ;-      -- -1   Only strongly right to left;-      -- -2   Like -1 but also contains neutrals.-    , _fHdrFontDirectionHint :: !Int16-      -- | 0 for short offsets, 1 for long.-    , _fHdrIndexToLocFormat  :: !Int16-      -- | 0 for current format.-    , _fHdrGlyphDataFormat   :: !Int16-    }-    deriving (Eq, Show)--instance NFData FontHeader where-  rnf (FontHeader {}) = ()--instance Binary FontHeader where-  put _ = fail "Unimplemented"-  get =-    FontHeader <$> get <*> get <*> g32 <*> g32 <*> get-               <*> g16 <*> g64 <*> g64 <*> get <*> get-               <*> get <*> get <*> get <*> g16 <*> gi16-               <*> gi16 <*> gi16-      where g16 = getWord16be-            g32 = getWord32be-            gi16 = fromIntegral <$> getWord16be-            g64 = getWord64be----- | Header flags.-data HeaderFlags = HeaderFlags-    { -- | Bit 0 - baseline for font at y=0;-      _hfBaselineY0           :: !Bool-      -- | Bit 1 - left sidebearing at x=0;-    , _hfLeftSideBearing      :: !Bool-      -- | Bit 2 - instructions may depend on point size;-    , _hfInstrDependPointSize :: !Bool-      -- | Bit 3 - force ppem to integer values for all internal-      -- scaler math; may use fractional ppem sizes if this bit-      -- is clear;-    , _hfForcePPEM            :: !Bool-      -- | Bit 4 - instructions may alter advance width (the-      -- advance widths might not scale linearly);-    , _hfAlterAdvance         :: !Bool-    }-    deriving (Eq, Show)--instance Binary HeaderFlags where-    get = do-      flags <- getWord16be-      let at ix = flags `testBit` ix-      return $ HeaderFlags (at 0) (at 1) (at 2) (at 3) (at 4)--    put (HeaderFlags a0 a1 a2 a3 a4) =-      putWord16be . foldl' setter 0 $ zip [0..] [a0, a1, a2, a3, a4]-        where setter acc (_, False) = acc-              setter acc (ix, True) = setBit acc ix-+{-# LANGUAGE CPP #-}
+module Graphics.Text.TrueType.Header
+    ( FontHeader( .. )
+    , FontStyle( .. )
+    , HeaderFlags( .. )
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<*>), (<$>) )
+#endif
+
+import Control.DeepSeq( NFData( .. ) )
+import Data.Bits( (.|.), setBit, testBit )
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( getWord16be
+                      , getWord32be
+                      , getWord64be
+                      )
+
+import Data.Binary.Put( putWord16be)
+
+import Data.Int( Int16 )
+import Data.List( foldl' )
+import Data.Word( Word16, Word32, Word64 )
+
+import Graphics.Text.TrueType.Types
+
+-- | Describe the basic stylistic properties
+-- of a font.
+data FontStyle = FontStyle
+  { _fontStyleBold   :: !Bool -- ^ If the font is bold.
+  , _fontStyleItalic :: !Bool -- ^ If the font is italic.
+  }
+  deriving (Eq, Ord, Show)
+
+instance Binary FontStyle where
+  put style = putWord16be $ italicByte .|. boldByte
+    where
+      boldByte
+        | _fontStyleBold style = 1
+        | otherwise = 0
+
+      italicByte
+        | _fontStyleItalic style = 2
+        | otherwise = 0
+
+  get = do
+    styleWord <- getWord16be 
+    let bitAt = testBit styleWord
+    return $ FontStyle (bitAt 0) (bitAt 1)
+
+-- | Font header
+data FontHeader = FontHeader
+    { -- | Table version number	0x00010000 for version 1.0.
+      _fHdrVersionNumber    :: !Fixed
+      -- | fontRevision	Set by font manufacturer.
+    , _fHdrFontRevision     :: !Fixed
+      -- | To compute:  set it to 0, sum the entire font as
+      -- ULONG, then store 0xB1B0AFBA - sum.
+    , _fHdrChecksumAdjust   :: !Word32
+     
+      -- | Should be equal to 0x5F0F3CF5.
+    , _fHdrMagicNumber      :: !Word32
+    , _fHdrFlags            :: !HeaderFlags
+
+      -- | Valid range is from 16 to 16384
+    , _fUnitsPerEm          :: !Word16
+      -- | International date (8-byte field).
+    , _fHdrCreateTime       :: !Word64
+      -- | International date (8-byte field).
+    , _fHdrModificationTime :: !Word64
+
+      -- | For all glyph bounding boxes.
+    , _fHdrxMin             :: !FWord
+      -- | For all glyph bounding boxes.
+    , _fHdrYMin             :: !FWord
+      -- | For all glyph bounding boxes.
+    , _fHdrXMax             :: !FWord
+      -- | For all glyph bounding boxes.
+    , _fHdrYMax             :: !FWord
+      -- | Bit 0 bold (if set to 1); Bit 1 italic (if set to 1)
+    , _fHdrMacStyle         :: !FontStyle
+      -- | Smallest readable size in pixels.
+    , _fHdrLowestRecPPEM    :: !Word16
+
+      -- | 0   Fully mixed directional glyphs;
+      --  1   Only strongly left to right;
+      --  2   Like 1 but also contains neutrals ;
+      -- -1   Only strongly right to left;
+      -- -2   Like -1 but also contains neutrals.
+    , _fHdrFontDirectionHint :: !Int16
+      -- | 0 for short offsets, 1 for long.
+    , _fHdrIndexToLocFormat  :: !Int16
+      -- | 0 for current format.
+    , _fHdrGlyphDataFormat   :: !Int16
+    }
+    deriving (Eq, Show)
+
+instance NFData FontHeader where
+  rnf (FontHeader {}) = ()
+
+instance Binary FontHeader where
+  put _ = fail "Unimplemented"
+  get =
+    FontHeader <$> get <*> get <*> g32 <*> g32 <*> get
+               <*> g16 <*> g64 <*> g64 <*> get <*> get
+               <*> get <*> get <*> get <*> g16 <*> gi16
+               <*> gi16 <*> gi16
+      where g16 = getWord16be
+            g32 = getWord32be
+            gi16 = fromIntegral <$> getWord16be
+            g64 = getWord64be
+
+
+-- | Header flags.
+data HeaderFlags = HeaderFlags
+    { -- | Bit 0 - baseline for font at y=0;
+      _hfBaselineY0           :: !Bool
+      -- | Bit 1 - left sidebearing at x=0;
+    , _hfLeftSideBearing      :: !Bool
+      -- | Bit 2 - instructions may depend on point size;
+    , _hfInstrDependPointSize :: !Bool
+      -- | Bit 3 - force ppem to integer values for all internal
+      -- scaler math; may use fractional ppem sizes if this bit
+      -- is clear;
+    , _hfForcePPEM            :: !Bool
+      -- | Bit 4 - instructions may alter advance width (the
+      -- advance widths might not scale linearly);
+    , _hfAlterAdvance         :: !Bool
+    }
+    deriving (Eq, Show)
+
+instance Binary HeaderFlags where
+    get = do
+      flags <- getWord16be
+      let at ix = flags `testBit` ix
+      return $ HeaderFlags (at 0) (at 1) (at 2) (at 3) (at 4)
+
+    put (HeaderFlags a0 a1 a2 a3 a4) =
+      putWord16be . foldl' setter 0 $ zip [0..] [a0, a1, a2, a3, a4]
+        where setter acc (_, False) = acc
+              setter acc (ix, True) = setBit acc ix
+

src/Graphics/Text/TrueType/HorizontalInfo.hs view

@@ -1,120 +1,120 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.HorizontalInfo-    ( HorizontalHeader( .. )-    , HorizontalMetricsTable( .. )-    , HorizontalMetric( .. )-    , getHorizontalMetrics-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-#endif--import Control.DeepSeq( NFData( .. ) )-import Control.Monad( when, replicateM_ )-import Data.Word( Word16 )-import Data.Int( Int16 )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( Get, getWord16be, getWord32be )-import Data.Binary.Put( putWord16be, putWord32be )-import qualified Data.Vector as V--import Graphics.Text.TrueType.Types---- | Describe the "hhea" TrueType table.-data HorizontalHeader = HorizontalHeader-    { -- | Distance from baseline of highest ascender-      _hheaAscent  :: {-# UNPACK #-} !FWord-      -- | Distance from baseline of lowest descender-    , _hheaDescent :: {-# UNPACK #-} !FWord-      -- | typographic line gap-    , _hheaLineGap :: {-# UNPACK #-} !FWord-      -- | must be consistent with horizontal metrics-    , _hheaAdvanceWidthMax :: {-# UNPACK #-} !FWord-      -- | must be consistent with horizontal metrics-    , _hheaMinLeftSideBearing :: {-# UNPACK #-} !FWord-      -- | must be consistent with horizontal metrics-    , _hheaMinRightSideBearing :: {-# UNPACK #-} !FWord-      -- | max(lsb + (xMax-xMin))-    , _hheaXmaxExtent :: {-# UNPACK #-} !FWord-      -- | used to calculate the slope of the caret -      -- (rise/run) set to 1 for vertical caret-    , _hheaCaretSlopeRise :: {-# UNPACK #-} !Int16-      -- | 0 for vertical-    , _hheaCaretSlopeRun :: {-# UNPACK #-} !Int16-      -- | set value to 0 for non-slanted fonts-    , _hheaCaretOffset  :: {-# UNPACK #-} !FWord-      -- | 0 for current format-    , _hheaMetricDataFormat :: {-# UNPACK #-} !Int16-      -- | number of advance widths in metrics table-    , _hheaLongHorMetricCount :: {-# UNPACK #-} !Word16-    }-    deriving (Eq, Show)--instance NFData HorizontalHeader where-    rnf (HorizontalHeader {}) = ()--instance Binary HorizontalHeader where-  put hdr = do-    putWord32be 0x00010000-    put $ _hheaAscent hdr-    put $ _hheaDescent hdr-    put $ _hheaLineGap hdr-    put $ _hheaAdvanceWidthMax hdr-    put $ _hheaMinLeftSideBearing hdr-    put $ _hheaMinRightSideBearing hdr-    put $ _hheaXmaxExtent hdr-    putWord16be . fromIntegral $ _hheaCaretSlopeRise hdr-    putWord16be . fromIntegral $ _hheaCaretSlopeRun hdr-    put $ _hheaCaretOffset hdr-    replicateM_ 4 $ putWord16be 0-    putWord16be . fromIntegral $ _hheaMetricDataFormat hdr-    putWord16be $ _hheaLongHorMetricCount hdr--  get = do-    ver <- getWord32be-    when (ver /= 0x00010000)-         (fail "Invalid HorizontalHeader (hhea) version")-    startHdr <- HorizontalHeader-            <$> get <*> get <*> get <*> get-            <*> get <*> get <*> get-            <*> (fromIntegral <$> getWord16be)-            <*> (fromIntegral <$> getWord16be)-            <*> get-    replicateM_ 4 getWord16be -- reserved, don't care-    startHdr <$> (fromIntegral <$> getWord16be)-             <*> getWord16be---- | Information of horizontal advance.-data HorizontalMetric = HorizontalMetric-    { _hmtxAdvanceWidth    :: {-# UNPACK #-} !Word16-    , _hmtxLeftSideBearing :: {-# UNPACK #-} !Int16-    }-    deriving (Eq, Show)--instance Binary HorizontalMetric where-    put (HorizontalMetric adv bear) =-      putWord16be adv >> putWord16be (fromIntegral bear)--    get = HorizontalMetric <$> g16 <*> (fromIntegral <$> g16)-      where g16 = getWord16be---- | For every glyph (indexed by the glyph index),--- provide horizontal information.-data HorizontalMetricsTable = HorizontalMetricsTable-    { _glyphMetrics :: !(V.Vector HorizontalMetric)-    }-    deriving (Eq, Show)--getHorizontalMetrics :: Int -- ^ Metrics count-                     -> Int -- ^ Glyph count-                     -> Get HorizontalMetricsTable-getHorizontalMetrics numberOfMetrics glyphCount = do-    hMetrics <- V.replicateM numberOfMetrics get-    let lastAdvance = _hmtxAdvanceWidth $ V.last hMetrics-    run <- V.replicateM sideBearingCount $-        HorizontalMetric lastAdvance . fromIntegral <$> getWord16be-    return $ HorizontalMetricsTable $ V.concat [hMetrics, run]-  where-    sideBearingCount = glyphCount - numberOfMetrics -+{-# LANGUAGE CPP #-}
+module Graphics.Text.TrueType.HorizontalInfo
+    ( HorizontalHeader( .. )
+    , HorizontalMetricsTable( .. )
+    , HorizontalMetric( .. )
+    , getHorizontalMetrics
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<*>), (<$>) )
+#endif
+
+import Control.DeepSeq( NFData( .. ) )
+import Control.Monad( when, replicateM_ )
+import Data.Word( Word16 )
+import Data.Int( Int16 )
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( Get, getWord16be, getWord32be )
+import Data.Binary.Put( putWord16be, putWord32be )
+import qualified Data.Vector as V
+
+import Graphics.Text.TrueType.Types
+
+-- | Describe the "hhea" TrueType table.
+data HorizontalHeader = HorizontalHeader
+    { -- | Distance from baseline of highest ascender
+      _hheaAscent  :: {-# UNPACK #-} !FWord
+      -- | Distance from baseline of lowest descender
+    , _hheaDescent :: {-# UNPACK #-} !FWord
+      -- | typographic line gap
+    , _hheaLineGap :: {-# UNPACK #-} !FWord
+      -- | must be consistent with horizontal metrics
+    , _hheaAdvanceWidthMax :: {-# UNPACK #-} !FWord
+      -- | must be consistent with horizontal metrics
+    , _hheaMinLeftSideBearing :: {-# UNPACK #-} !FWord
+      -- | must be consistent with horizontal metrics
+    , _hheaMinRightSideBearing :: {-# UNPACK #-} !FWord
+      -- | max(lsb + (xMax-xMin))
+    , _hheaXmaxExtent :: {-# UNPACK #-} !FWord
+      -- | used to calculate the slope of the caret 
+      -- (rise/run) set to 1 for vertical caret
+    , _hheaCaretSlopeRise :: {-# UNPACK #-} !Int16
+      -- | 0 for vertical
+    , _hheaCaretSlopeRun :: {-# UNPACK #-} !Int16
+      -- | set value to 0 for non-slanted fonts
+    , _hheaCaretOffset  :: {-# UNPACK #-} !FWord
+      -- | 0 for current format
+    , _hheaMetricDataFormat :: {-# UNPACK #-} !Int16
+      -- | number of advance widths in metrics table
+    , _hheaLongHorMetricCount :: {-# UNPACK #-} !Word16
+    }
+    deriving (Eq, Show)
+
+instance NFData HorizontalHeader where
+    rnf (HorizontalHeader {}) = ()
+
+instance Binary HorizontalHeader where
+  put hdr = do
+    putWord32be 0x00010000
+    put $ _hheaAscent hdr
+    put $ _hheaDescent hdr
+    put $ _hheaLineGap hdr
+    put $ _hheaAdvanceWidthMax hdr
+    put $ _hheaMinLeftSideBearing hdr
+    put $ _hheaMinRightSideBearing hdr
+    put $ _hheaXmaxExtent hdr
+    putWord16be . fromIntegral $ _hheaCaretSlopeRise hdr
+    putWord16be . fromIntegral $ _hheaCaretSlopeRun hdr
+    put $ _hheaCaretOffset hdr
+    replicateM_ 4 $ putWord16be 0
+    putWord16be . fromIntegral $ _hheaMetricDataFormat hdr
+    putWord16be $ _hheaLongHorMetricCount hdr
+
+  get = do
+    ver <- getWord32be
+    when (ver /= 0x00010000)
+         (fail "Invalid HorizontalHeader (hhea) version")
+    startHdr <- HorizontalHeader
+            <$> get <*> get <*> get <*> get
+            <*> get <*> get <*> get
+            <*> (fromIntegral <$> getWord16be)
+            <*> (fromIntegral <$> getWord16be)
+            <*> get
+    replicateM_ 4 getWord16be -- reserved, don't care
+    startHdr <$> (fromIntegral <$> getWord16be)
+             <*> getWord16be
+
+-- | Information of horizontal advance.
+data HorizontalMetric = HorizontalMetric
+    { _hmtxAdvanceWidth    :: {-# UNPACK #-} !Word16
+    , _hmtxLeftSideBearing :: {-# UNPACK #-} !Int16
+    }
+    deriving (Eq, Show)
+
+instance Binary HorizontalMetric where
+    put (HorizontalMetric adv bear) =
+      putWord16be adv >> putWord16be (fromIntegral bear)
+
+    get = HorizontalMetric <$> g16 <*> (fromIntegral <$> g16)
+      where g16 = getWord16be
+
+-- | For every glyph (indexed by the glyph index),
+-- provide horizontal information.
+data HorizontalMetricsTable = HorizontalMetricsTable
+    { _glyphMetrics :: !(V.Vector HorizontalMetric)
+    }
+    deriving (Eq, Show)
+
+getHorizontalMetrics :: Int -- ^ Metrics count
+                     -> Int -- ^ Glyph count
+                     -> Get HorizontalMetricsTable
+getHorizontalMetrics numberOfMetrics glyphCount = do
+    hMetrics <- V.replicateM numberOfMetrics get
+    let lastAdvance = _hmtxAdvanceWidth $ V.last hMetrics
+    run <- V.replicateM sideBearingCount $
+        HorizontalMetric lastAdvance . fromIntegral <$> getWord16be
+    return $ HorizontalMetricsTable $ V.concat [hMetrics, run]
+  where
+    sideBearingCount = glyphCount - numberOfMetrics 
+

src/Graphics/Text/TrueType/LanguageIds.hs view

@@ -1,331 +1,342 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.LanguageIds-    ( PlatformId( .. )-    , UnicodePlatformSpecific( .. )-    , MacPlatformId( .. )-    , MacLanguage( .. )-    , platformToWord-    , unicodePlatformSpecificToId-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>) )-#endif--import Data.Binary( Binary( .. ) )-import Data.Binary.Get( getWord16be )-import Data.Binary.Put( putWord16be )-import Data.Word( Word16 )-import qualified Data.Map.Strict as M--data PlatformId-    = PlatformUnicode   -- ^ 0-    | PlatformMacintosh -- ^ 1-    | PlatformISO       -- ^ 2-    | PlatformWindows   -- ^ 3-    | PlatformCustom    -- ^ 4-    | PlatformId Word16-    deriving (Eq, Ord, Show)--instance Binary PlatformId where-    put = putWord16be . platformToWord-    get = do-      val <- getWord16be-      return $ case val of-        0 -> PlatformUnicode-        1 -> PlatformMacintosh-        2 -> PlatformISO-        3 -> PlatformWindows-        4 -> PlatformCustom-        n -> PlatformId n--platformToWord :: PlatformId -> Word16-platformToWord = p where-  p PlatformUnicode = 0-  p PlatformMacintosh = 1-  p PlatformISO = 2-  p PlatformWindows = 3-  p PlatformCustom = 4-  p (PlatformId v) = v--data UnicodePlatformSpecific-    = UnicodePlatform1_0-    | UnicodePlatform1_1-    | UnicodeISO10645-    | UnicodeBMPOnly2_0-    | UnicodeFull2_0-    | UnicodeVariation-    | UnicodeFull-    deriving (Eq, Show)--unicodePlatformSpecificToId :: UnicodePlatformSpecific -> Word16-unicodePlatformSpecificToId = go-  where-    go UnicodePlatform1_0 = 0-    go UnicodePlatform1_1 = 1-    go UnicodeISO10645    = 2-    go UnicodeBMPOnly2_0  = 3-    go UnicodeFull2_0     = 4-    go UnicodeVariation   = 5-    go UnicodeFull        = 6--instance Binary UnicodePlatformSpecific where-    put = putWord16be . unicodePlatformSpecificToId --    get = do-       v <- getWord16be-       return $ case v of-          0 -> UnicodePlatform1_0-          1 -> UnicodePlatform1_1-          2 -> UnicodeISO10645-          3 -> UnicodeBMPOnly2_0-          4 -> UnicodeFull2_0-          5 -> UnicodeVariation-          6 -> UnicodeFull-          _ -> UnicodeFull--data MacPlatformId-   = MacSpecificRoman-   | MacSpecificJapanese-   | MacSpecificChineseTraditional-   | MacSpecificKorean-   | MacSpecificArabic-   | MacSpecificHebrew-   | MacSpecificGreek-   | MacSpecificRussian-   | MacSpecificRSymbol-   | MacSpecificDevanagari-   | MacSpecificGurmukhi-   | MacSpecificGujarati-   | MacSpecificOriya-   | MacSpecificBengali-   | MacSpecificTamil-   | MacSpecificTelugu-   | MacSpecificKannada-   | MacSpecificMalayalam-   | MacSpecificSinhalese-   | MacSpecificBurmese-   | MacSpecificKhmer-   | MacSpecificThai-   | MacSpecificLaotian-   | MacSpecificGeorgian-   | MacSpecificArmenian-   | MacSpecificChineseSimplified-   | MacSpecificTibetan-   | MacSpecificMongolian-   | MacSpecificGeez-   | MacSpecificSlavic-   | MacSpecificVietnamese-   | MacSpecificSindhi-   | MacSpecificUninterpreted-   deriving (Eq, Ord, Show)--macSpecifcIdList :: [MacPlatformId]-macSpecifcIdList =-    [ MacSpecificRoman, MacSpecificJapanese, MacSpecificChineseTraditional-    , MacSpecificKorean, MacSpecificArabic, MacSpecificHebrew-    , MacSpecificGreek, MacSpecificRussian, MacSpecificRSymbol-    , MacSpecificDevanagari, MacSpecificGurmukhi, MacSpecificGujarati-    , MacSpecificOriya, MacSpecificBengali, MacSpecificTamil-    , MacSpecificTelugu, MacSpecificKannada, MacSpecificMalayalam-    , MacSpecificSinhalese, MacSpecificBurmese, MacSpecificKhmer-    , MacSpecificThai, MacSpecificLaotian, MacSpecificGeorgian-    , MacSpecificArmenian, MacSpecificChineseSimplified, MacSpecificTibetan-    , MacSpecificMongolian, MacSpecificGeez, MacSpecificSlavic-    , MacSpecificVietnamese, MacSpecificSindhi, MacSpecificUninterpreted-    ]---prepareSpecificMaps :: Ord a => [a] -> (M.Map a Word16, M.Map Word16 a)-prepareSpecificMaps lst = (toWord, toPlatform)-  where-    toWord = M.fromList $ zip lst [0 ..]-    toPlatform = M.fromList $ zip [0 ..] lst--mapSpecifcIdMaps :: ( M.Map MacPlatformId Word16-                    , M.Map Word16 MacPlatformId )-mapSpecifcIdMaps = prepareSpecificMaps macSpecifcIdList--instance Binary MacPlatformId where-    get = finder <$> getWord16be-      where-        (_, to) = mapSpecifcIdMaps-        finder v = M.findWithDefault MacSpecificUninterpreted v to--    put v = putWord16be val-      where-        (from, _) = mapSpecifcIdMaps-        val = M.findWithDefault 32 v from--data MacLanguage-    = MacLangEnglish-    | MacLangFrench-    | MacLangGerman-    | MacLangItalian-    | MacLangDutch-    | MacLangSwedish-    | MacLangSpanish-    | MacLangDanish-    | MacLangPortuguese-    | MacLangNorwegian-    | MacLangHebrew-    | MacLangJapanese-    | MacLangArabic-    | MacLangFinnish-    | MacLangGreek-    | MacLangInuktitut-    | MacLangIcelandic-    | MacLangMaltese-    | MacLangTurkish-    | MacLangCroatian-    | MacLangChineseTraditional-    | MacLangUrdu-    | MacLangHindi-    | MacLangThai-    | MacLangKorean-    | MacLangLithuanian-    | MacLangPolish-    | MacLangHungarian-    | MacLangEstonian-    | MacLangLatvian-    | MacLangSami-    | MacLangFaroese-    | MacLangFarsiPersian-    | MacLangRussian-    | MacLangChineseSimplified-    | MacLangFlemish-    | MacLangIrishGaelic-    | MacLangAlbanian-    | MacLangRomanian-    | MacLangCzech-    | MacLangSlovak-    | MacLangSlovenian-    | MacLangYiddish-    | MacLangSerbian-    | MacLangMacedonian-    | MacLangBulgarian-    | MacLangUkrainian-    | MacLangByelorussian-    | MacLangUzbek-    | MacLangKazakh-    | MacLangAzerbaijaniCyrillic-    | MacLangAzerbaijaniArabic-    | MacLangArmenian-    | MacLangGeorgian-    | MacLangMoldavian-    | MacLangKirghiz-    | MacLangTajiki-    | MacLangTurkmen-    | MacLangMongolian-    | MacLangMongolianCyrillic-    | MacLangPashto-    | MacLangKurdish-    | MacLangKashmiri-    | MacLangSindhi-    | MacLangTibetan-    | MacLangNepali-    | MacLangSanskrit-    | MacLangMarathi-    | MacLangBengali-    | MacLangAssamese-    | MacLangGujarati-    | MacLangPunjabi-    | MacLangOriya-    | MacLangMalayalam-    | MacLangKannada-    | MacLangTamil-    | MacLangTelugu-    | MacLangSinhalese-    | MacLangBurmese-    | MacLangKhmer-    | MacLangLao-    | MacLangVietnamese-    | MacLangIndonesian-    | MacLangTagalong-    | MacLangMalayRoman-    | MacLangMalayArabic-    | MacLangAmharic-    | MacLangTigrinya-    | MacLangGalla-    | MacLangSomali-    | MacLangSwahili-    | MacLangKinyarwandaRuanda-    | MacLangRundi-    | MacLangNyanjaChewa-    | MacLangMalagasy-    | MacLangEsperanto-    | MacLangWelsh-    | MacLangBasque-    | MacLangCatalan-    | MacLangLatin-    | MacLangQuenchua-    | MacLangGuarani-    | MacLangAymara-    | MacLangTatar-    | MacLangUighur-    | MacLangDzongkha-    | MacLangJavanese-    | MacLangSundanese-    | MacLangGalician-    | MacLangAfrikaans-    | MacLangBreton-    | MacLangScottishGaelic-    | MacLangManxGaelic-    | MacLangIrishGaelicWithDot-    | MacLangTongan-    | MacLangGreekPolytonic-    | MacLangGreenlandic-    | MacLangAzerbaijani-    deriving (Eq, Ord, Show)--macLangList :: [MacLanguage]-macLangList =-    [ MacLangEnglish , MacLangFrench , MacLangGerman , MacLangItalian-    , MacLangDutch , MacLangSwedish , MacLangSpanish , MacLangDanish-    , MacLangPortuguese , MacLangNorwegian , MacLangHebrew , MacLangJapanese-    , MacLangArabic , MacLangFinnish , MacLangGreek , MacLangInuktitut-    , MacLangIcelandic , MacLangMaltese , MacLangTurkish , MacLangCroatian-    , MacLangChineseTraditional , MacLangUrdu , MacLangHindi , MacLangThai-    , MacLangKorean , MacLangLithuanian , MacLangPolish , MacLangHungarian-    , MacLangEstonian , MacLangLatvian , MacLangSami , MacLangFaroese-    , MacLangFarsiPersian , MacLangRussian , MacLangChineseSimplified-    , MacLangFlemish-    , MacLangIrishGaelic , MacLangAlbanian , MacLangRomanian , MacLangCzech-    , MacLangSlovak , MacLangSlovenian , MacLangYiddish , MacLangSerbian-    , MacLangMacedonian , MacLangBulgarian , MacLangUkrainian , MacLangByelorussian-    , MacLangUzbek , MacLangKazakh , MacLangAzerbaijaniCyrillic-    , MacLangAzerbaijaniArabic-    , MacLangArmenian , MacLangGeorgian , MacLangMoldavian , MacLangKirghiz-    , MacLangTajiki , MacLangTurkmen , MacLangMongolian , MacLangMongolianCyrillic-    , MacLangPashto , MacLangKurdish , MacLangKashmiri , MacLangSindhi-    , MacLangTibetan , MacLangNepali , MacLangSanskrit , MacLangMarathi-    , MacLangBengali , MacLangAssamese , MacLangGujarati , MacLangPunjabi-    , MacLangOriya , MacLangMalayalam , MacLangKannada , MacLangTamil-    , MacLangTelugu , MacLangSinhalese , MacLangBurmese , MacLangKhmer-    , MacLangLao , MacLangVietnamese , MacLangIndonesian , MacLangTagalong-    , MacLangMalayRoman , MacLangMalayArabic , MacLangAmharic , MacLangTigrinya-    , MacLangGalla , MacLangSomali , MacLangSwahili , MacLangKinyarwandaRuanda-    , MacLangRundi , MacLangNyanjaChewa , MacLangMalagasy , MacLangEsperanto-    , MacLangWelsh , MacLangBasque , MacLangCatalan , MacLangLatin-    , MacLangQuenchua , MacLangGuarani , MacLangAymara , MacLangTatar-    , MacLangUighur , MacLangDzongkha , MacLangJavanese , MacLangSundanese-    , MacLangGalician , MacLangAfrikaans , MacLangBreton , MacLangScottishGaelic-    , MacLangManxGaelic , MacLangIrishGaelicWithDot , MacLangTongan-    , MacLangGreekPolytonic , MacLangGreenlandic , MacLangAzerbaijani-    ]--mapLangIdMaps :: (M.Map MacLanguage Word16, M.Map Word16 MacLanguage)-mapLangIdMaps = prepareSpecificMaps macLangList--instance Binary MacLanguage where-    get = finder <$> getWord16be-      where-        (_, to) = mapLangIdMaps-        finder v = M.findWithDefault MacLangEnglish v to--    put v = putWord16be val-      where-        (from, _) = mapLangIdMaps-        val = M.findWithDefault 0 v from-+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+module Graphics.Text.TrueType.LanguageIds
+    ( PlatformId( .. )
+    , UnicodePlatformSpecific( .. )
+    , MacPlatformId( .. )
+    , MacLanguage( .. )
+    , platformToWord
+    , unicodePlatformSpecificToId
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<$>) )
+#endif
+
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( getWord16be )
+import Data.Binary.Put( putWord16be )
+import Data.Word( Word16 )
+import qualified Data.Map.Strict as M
+
+-- Note [PlatformID sorting]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Unicode and Windows are the two preferred encodings according to Apple's
+-- documentation. Indeed some fonts (e.g., Bitstream Vera Mono) return the wrong
+-- glyphs if we use Macintosh encoding instead of Windows one.
+--
+-- To fix this, the Ord instance for PlatformId ensures that:
+--    Unicode < Windows < Macintosh
+-- 
+
+data PlatformId
+    = PlatformUnicode   -- ^ 0 Don't change the ordering (see Note [PlatformID sorting])
+    | PlatformWindows   -- ^ 3 
+    | PlatformMacintosh -- ^ 1
+    | PlatformISO       -- ^ 2
+    | PlatformCustom    -- ^ 4
+    | PlatformId Word16
+    deriving (Eq, Ord, Show)
+
+instance Binary PlatformId where
+    put = putWord16be . platformToWord
+    get = do
+      val <- getWord16be
+      return $ case val of
+        0 -> PlatformUnicode
+        1 -> PlatformMacintosh
+        2 -> PlatformISO
+        3 -> PlatformWindows
+        4 -> PlatformCustom
+        n -> PlatformId n
+
+platformToWord :: PlatformId -> Word16
+platformToWord = p where
+  p PlatformUnicode = 0
+  p PlatformMacintosh = 1
+  p PlatformISO = 2
+  p PlatformWindows = 3
+  p PlatformCustom = 4
+  p (PlatformId v) = v
+
+data UnicodePlatformSpecific
+    = UnicodePlatform1_0
+    | UnicodePlatform1_1
+    | UnicodeISO10645
+    | UnicodeBMPOnly2_0
+    | UnicodeFull2_0
+    | UnicodeVariation
+    | UnicodeFull
+    deriving (Eq, Show)
+
+unicodePlatformSpecificToId :: UnicodePlatformSpecific -> Word16
+unicodePlatformSpecificToId = go
+  where
+    go UnicodePlatform1_0 = 0
+    go UnicodePlatform1_1 = 1
+    go UnicodeISO10645    = 2
+    go UnicodeBMPOnly2_0  = 3
+    go UnicodeFull2_0     = 4
+    go UnicodeVariation   = 5
+    go UnicodeFull        = 6
+
+instance Binary UnicodePlatformSpecific where
+    put = putWord16be . unicodePlatformSpecificToId 
+
+    get = do
+       v <- getWord16be
+       return $ case v of
+          0 -> UnicodePlatform1_0
+          1 -> UnicodePlatform1_1
+          2 -> UnicodeISO10645
+          3 -> UnicodeBMPOnly2_0
+          4 -> UnicodeFull2_0
+          5 -> UnicodeVariation
+          6 -> UnicodeFull
+          _ -> UnicodeFull
+
+data MacPlatformId
+   = MacSpecificRoman
+   | MacSpecificJapanese
+   | MacSpecificChineseTraditional
+   | MacSpecificKorean
+   | MacSpecificArabic
+   | MacSpecificHebrew
+   | MacSpecificGreek
+   | MacSpecificRussian
+   | MacSpecificRSymbol
+   | MacSpecificDevanagari
+   | MacSpecificGurmukhi
+   | MacSpecificGujarati
+   | MacSpecificOriya
+   | MacSpecificBengali
+   | MacSpecificTamil
+   | MacSpecificTelugu
+   | MacSpecificKannada
+   | MacSpecificMalayalam
+   | MacSpecificSinhalese
+   | MacSpecificBurmese
+   | MacSpecificKhmer
+   | MacSpecificThai
+   | MacSpecificLaotian
+   | MacSpecificGeorgian
+   | MacSpecificArmenian
+   | MacSpecificChineseSimplified
+   | MacSpecificTibetan
+   | MacSpecificMongolian
+   | MacSpecificGeez
+   | MacSpecificSlavic
+   | MacSpecificVietnamese
+   | MacSpecificSindhi
+   | MacSpecificUninterpreted
+   deriving (Eq, Ord, Show)
+
+macSpecifcIdList :: [MacPlatformId]
+macSpecifcIdList =
+    [ MacSpecificRoman, MacSpecificJapanese, MacSpecificChineseTraditional
+    , MacSpecificKorean, MacSpecificArabic, MacSpecificHebrew
+    , MacSpecificGreek, MacSpecificRussian, MacSpecificRSymbol
+    , MacSpecificDevanagari, MacSpecificGurmukhi, MacSpecificGujarati
+    , MacSpecificOriya, MacSpecificBengali, MacSpecificTamil
+    , MacSpecificTelugu, MacSpecificKannada, MacSpecificMalayalam
+    , MacSpecificSinhalese, MacSpecificBurmese, MacSpecificKhmer
+    , MacSpecificThai, MacSpecificLaotian, MacSpecificGeorgian
+    , MacSpecificArmenian, MacSpecificChineseSimplified, MacSpecificTibetan
+    , MacSpecificMongolian, MacSpecificGeez, MacSpecificSlavic
+    , MacSpecificVietnamese, MacSpecificSindhi, MacSpecificUninterpreted
+    ]
+
+
+prepareSpecificMaps :: Ord a => [a] -> (M.Map a Word16, M.Map Word16 a)
+prepareSpecificMaps lst = (toWord, toPlatform)
+  where
+    toWord = M.fromList $ zip lst [0 ..]
+    toPlatform = M.fromList $ zip [0 ..] lst
+
+mapSpecifcIdMaps :: ( M.Map MacPlatformId Word16
+                    , M.Map Word16 MacPlatformId )
+mapSpecifcIdMaps = prepareSpecificMaps macSpecifcIdList
+
+instance Binary MacPlatformId where
+    get = finder <$> getWord16be
+      where
+        (_, to) = mapSpecifcIdMaps
+        finder v = M.findWithDefault MacSpecificUninterpreted v to
+
+    put v = putWord16be val
+      where
+        (from, _) = mapSpecifcIdMaps
+        val = M.findWithDefault 32 v from
+
+data MacLanguage
+    = MacLangEnglish
+    | MacLangFrench
+    | MacLangGerman
+    | MacLangItalian
+    | MacLangDutch
+    | MacLangSwedish
+    | MacLangSpanish
+    | MacLangDanish
+    | MacLangPortuguese
+    | MacLangNorwegian
+    | MacLangHebrew
+    | MacLangJapanese
+    | MacLangArabic
+    | MacLangFinnish
+    | MacLangGreek
+    | MacLangInuktitut
+    | MacLangIcelandic
+    | MacLangMaltese
+    | MacLangTurkish
+    | MacLangCroatian
+    | MacLangChineseTraditional
+    | MacLangUrdu
+    | MacLangHindi
+    | MacLangThai
+    | MacLangKorean
+    | MacLangLithuanian
+    | MacLangPolish
+    | MacLangHungarian
+    | MacLangEstonian
+    | MacLangLatvian
+    | MacLangSami
+    | MacLangFaroese
+    | MacLangFarsiPersian
+    | MacLangRussian
+    | MacLangChineseSimplified
+    | MacLangFlemish
+    | MacLangIrishGaelic
+    | MacLangAlbanian
+    | MacLangRomanian
+    | MacLangCzech
+    | MacLangSlovak
+    | MacLangSlovenian
+    | MacLangYiddish
+    | MacLangSerbian
+    | MacLangMacedonian
+    | MacLangBulgarian
+    | MacLangUkrainian
+    | MacLangByelorussian
+    | MacLangUzbek
+    | MacLangKazakh
+    | MacLangAzerbaijaniCyrillic
+    | MacLangAzerbaijaniArabic
+    | MacLangArmenian
+    | MacLangGeorgian
+    | MacLangMoldavian
+    | MacLangKirghiz
+    | MacLangTajiki
+    | MacLangTurkmen
+    | MacLangMongolian
+    | MacLangMongolianCyrillic
+    | MacLangPashto
+    | MacLangKurdish
+    | MacLangKashmiri
+    | MacLangSindhi
+    | MacLangTibetan
+    | MacLangNepali
+    | MacLangSanskrit
+    | MacLangMarathi
+    | MacLangBengali
+    | MacLangAssamese
+    | MacLangGujarati
+    | MacLangPunjabi
+    | MacLangOriya
+    | MacLangMalayalam
+    | MacLangKannada
+    | MacLangTamil
+    | MacLangTelugu
+    | MacLangSinhalese
+    | MacLangBurmese
+    | MacLangKhmer
+    | MacLangLao
+    | MacLangVietnamese
+    | MacLangIndonesian
+    | MacLangTagalong
+    | MacLangMalayRoman
+    | MacLangMalayArabic
+    | MacLangAmharic
+    | MacLangTigrinya
+    | MacLangGalla
+    | MacLangSomali
+    | MacLangSwahili
+    | MacLangKinyarwandaRuanda
+    | MacLangRundi
+    | MacLangNyanjaChewa
+    | MacLangMalagasy
+    | MacLangEsperanto
+    | MacLangWelsh
+    | MacLangBasque
+    | MacLangCatalan
+    | MacLangLatin
+    | MacLangQuenchua
+    | MacLangGuarani
+    | MacLangAymara
+    | MacLangTatar
+    | MacLangUighur
+    | MacLangDzongkha
+    | MacLangJavanese
+    | MacLangSundanese
+    | MacLangGalician
+    | MacLangAfrikaans
+    | MacLangBreton
+    | MacLangScottishGaelic
+    | MacLangManxGaelic
+    | MacLangIrishGaelicWithDot
+    | MacLangTongan
+    | MacLangGreekPolytonic
+    | MacLangGreenlandic
+    | MacLangAzerbaijani
+    deriving (Eq, Ord, Show)
+
+macLangList :: [MacLanguage]
+macLangList =
+    [ MacLangEnglish , MacLangFrench , MacLangGerman , MacLangItalian
+    , MacLangDutch , MacLangSwedish , MacLangSpanish , MacLangDanish
+    , MacLangPortuguese , MacLangNorwegian , MacLangHebrew , MacLangJapanese
+    , MacLangArabic , MacLangFinnish , MacLangGreek , MacLangInuktitut
+    , MacLangIcelandic , MacLangMaltese , MacLangTurkish , MacLangCroatian
+    , MacLangChineseTraditional , MacLangUrdu , MacLangHindi , MacLangThai
+    , MacLangKorean , MacLangLithuanian , MacLangPolish , MacLangHungarian
+    , MacLangEstonian , MacLangLatvian , MacLangSami , MacLangFaroese
+    , MacLangFarsiPersian , MacLangRussian , MacLangChineseSimplified
+    , MacLangFlemish
+    , MacLangIrishGaelic , MacLangAlbanian , MacLangRomanian , MacLangCzech
+    , MacLangSlovak , MacLangSlovenian , MacLangYiddish , MacLangSerbian
+    , MacLangMacedonian , MacLangBulgarian , MacLangUkrainian , MacLangByelorussian
+    , MacLangUzbek , MacLangKazakh , MacLangAzerbaijaniCyrillic
+    , MacLangAzerbaijaniArabic
+    , MacLangArmenian , MacLangGeorgian , MacLangMoldavian , MacLangKirghiz
+    , MacLangTajiki , MacLangTurkmen , MacLangMongolian , MacLangMongolianCyrillic
+    , MacLangPashto , MacLangKurdish , MacLangKashmiri , MacLangSindhi
+    , MacLangTibetan , MacLangNepali , MacLangSanskrit , MacLangMarathi
+    , MacLangBengali , MacLangAssamese , MacLangGujarati , MacLangPunjabi
+    , MacLangOriya , MacLangMalayalam , MacLangKannada , MacLangTamil
+    , MacLangTelugu , MacLangSinhalese , MacLangBurmese , MacLangKhmer
+    , MacLangLao , MacLangVietnamese , MacLangIndonesian , MacLangTagalong
+    , MacLangMalayRoman , MacLangMalayArabic , MacLangAmharic , MacLangTigrinya
+    , MacLangGalla , MacLangSomali , MacLangSwahili , MacLangKinyarwandaRuanda
+    , MacLangRundi , MacLangNyanjaChewa , MacLangMalagasy , MacLangEsperanto
+    , MacLangWelsh , MacLangBasque , MacLangCatalan , MacLangLatin
+    , MacLangQuenchua , MacLangGuarani , MacLangAymara , MacLangTatar
+    , MacLangUighur , MacLangDzongkha , MacLangJavanese , MacLangSundanese
+    , MacLangGalician , MacLangAfrikaans , MacLangBreton , MacLangScottishGaelic
+    , MacLangManxGaelic , MacLangIrishGaelicWithDot , MacLangTongan
+    , MacLangGreekPolytonic , MacLangGreenlandic , MacLangAzerbaijani
+    ]
+
+mapLangIdMaps :: (M.Map MacLanguage Word16, M.Map Word16 MacLanguage)
+mapLangIdMaps = prepareSpecificMaps macLangList
+
+instance Binary MacLanguage where
+    get = finder <$> getWord16be
+      where
+        (_, to) = mapLangIdMaps
+        finder v = M.findWithDefault MacLangEnglish v to
+
+    put v = putWord16be val
+      where
+        (from, _) = mapLangIdMaps
+        val = M.findWithDefault 0 v from
+

src/Graphics/Text/TrueType/MaxpTable.hs view

@@ -1,59 +1,59 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.MaxpTable( MaxpTable( .. ) ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-#endif--import Control.DeepSeq( NFData( .. ) )-import Data.Word( Word16 )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( getWord16be )--import Graphics.Text.TrueType.Types--data MaxpTable = MaxpTable -    { -- | version number	0x00010000 for version 1.0.-      _maxpTableVersion :: !Fixed-    -- | The number of glyphs in the font.-    , _maxpnumGlyphs :: !Word16-    -- | Maximum points in a non-composite glyph.-    , _maxpmaxPoints :: !Word16-    -- | Maximum contours in a non-composite glyph.-    , _maxpmaxContours :: !Word16-    -- | Maximum points in a composite glyph.-    , _maxpmaxCompositePoints :: !Word16-    -- | Maximum contours in a composite glyph.-    , _maxpmaxCompositeContours :: !Word16-    -- | 1 if instructions do not use the twilight zone (Z0), or 2 if instructions do use Z0; should be set to 2 in most cases.-    , _maxpmaxZones :: !Word16-    -- | Maximum points used in Z0.-    , _maxpmaxTwilightPoints :: !Word16-    -- | Number of Storage Area locations. -    , _maxpmaxStorage :: !Word16-    -- | Number of FDEFs.-    , _maxpmaxFunctionDefs :: !Word16-    -- | Number of IDEFs.-    , _maxpmaxInstructionDefs :: !Word16-    -- | Maximum stack depth .-    , _maxpmaxStackElements :: !Word16-    -- | Maximum byte count for glyph instructions.-    , _maxpmaxSizeOfInstructions :: !Word16-    -- | Maximum number of components referenced at "top level" for any composite glyph.-    , _maxpmaxComponentElements :: !Word16-    -- | Maximum levels of recursion; 1 for simple components.-    , _maxpmaxComponentDepth :: !Word16-    }-    deriving (Eq, Show)--instance NFData MaxpTable where-    rnf (MaxpTable {}) = ()--instance Binary MaxpTable where-    put _ = fail "Unimplemented"-    get = MaxpTable -       <$> get <*> g16 <*> g16 <*> g16 <*> g16 <*> g16-       <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 <*> g16-       <*> g16 <*> g16 <*> g16-         where g16 = getWord16be-+{-# LANGUAGE CPP #-}
+module Graphics.Text.TrueType.MaxpTable( MaxpTable( .. ) ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<*>), (<$>) )
+#endif
+
+import Control.DeepSeq( NFData( .. ) )
+import Data.Word( Word16 )
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( getWord16be )
+
+import Graphics.Text.TrueType.Types
+
+data MaxpTable = MaxpTable 
+    { -- | version number	0x00010000 for version 1.0.
+      _maxpTableVersion :: !Fixed
+    -- | The number of glyphs in the font.
+    , _maxpnumGlyphs :: !Word16
+    -- | Maximum points in a non-composite glyph.
+    , _maxpmaxPoints :: !Word16
+    -- | Maximum contours in a non-composite glyph.
+    , _maxpmaxContours :: !Word16
+    -- | Maximum points in a composite glyph.
+    , _maxpmaxCompositePoints :: !Word16
+    -- | Maximum contours in a composite glyph.
+    , _maxpmaxCompositeContours :: !Word16
+    -- | 1 if instructions do not use the twilight zone (Z0), or 2 if instructions do use Z0; should be set to 2 in most cases.
+    , _maxpmaxZones :: !Word16
+    -- | Maximum points used in Z0.
+    , _maxpmaxTwilightPoints :: !Word16
+    -- | Number of Storage Area locations. 
+    , _maxpmaxStorage :: !Word16
+    -- | Number of FDEFs.
+    , _maxpmaxFunctionDefs :: !Word16
+    -- | Number of IDEFs.
+    , _maxpmaxInstructionDefs :: !Word16
+    -- | Maximum stack depth .
+    , _maxpmaxStackElements :: !Word16
+    -- | Maximum byte count for glyph instructions.
+    , _maxpmaxSizeOfInstructions :: !Word16
+    -- | Maximum number of components referenced at "top level" for any composite glyph.
+    , _maxpmaxComponentElements :: !Word16
+    -- | Maximum levels of recursion; 1 for simple components.
+    , _maxpmaxComponentDepth :: !Word16
+    }
+    deriving (Eq, Show)
+
+instance NFData MaxpTable where
+    rnf (MaxpTable {}) = ()
+
+instance Binary MaxpTable where
+    put _ = fail "Unimplemented"
+    get = MaxpTable 
+       <$> get <*> g16 <*> g16 <*> g16 <*> g16 <*> g16
+       <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 <*> g16
+       <*> g16 <*> g16 <*> g16
+         where g16 = getWord16be
+

src/Graphics/Text/TrueType/Name.hs view

@@ -1,122 +1,122 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.Name-    ( NameTable-    , NameRecords-    , fontFamilyName-    ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( mempty )-import Control.Applicative( (<$>), (<*>), pure )-#endif--import Control.DeepSeq( NFData( .. ) )-import Control.Monad( when, replicateM )-import Data.Foldable( asum )-import Data.Function( on )-import Data.List( maximumBy )-import Data.Maybe( fromMaybe )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( getWord16be, getByteString )-import Data.Binary.Put( putWord16be )-import Data.Word( Word16 )-import qualified Data.Vector as V-import qualified Data.ByteString as B-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE--import Graphics.Text.TrueType.LanguageIds--data NameTable = NameTable-    { _ntRecords      :: !(V.Vector NameRecords) }-    deriving Show--instance NFData NameTable where-    rnf (NameTable {}) = ()--instance Binary NameTable where-  put _ = fail "Binary.put NameTable - unimplemented"-  get = do-    nameFormatId <- getWord16be-    when (nameFormatId /= 0) $-          fail "Invalid name table format"-    count <- getWord16be-    stringOffset <- getWord16be-    records <- replicateM (fromIntegral count) get-    let maxRec = maximumBy (compare `on` _nrOffset) records-        toFetch = fromIntegral (_nrOffset maxRec) + fromIntegral (_nrLength maxRec)-                - fromIntegral stringOffset--    strTable <- getByteString toFetch-    let fetcher r = r { _nrString = B.take iLength $ B.drop iOffset strTable }-          where iLength = fromIntegral $ _nrLength r-                iOffset = fromIntegral $ _nrOffset r--    return . NameTable . V.fromListN (fromIntegral count) $ map fetcher records--data NameRecords = NameRecords-    { _nrPlatoformId        :: {-# UNPACK #-} !Word16-    , _nrPlatformSpecificId :: {-# UNPACK #-} !Word16-    , _nrLanguageId         :: {-# UNPACK #-} !Word16-    , _nrNameId             :: {-# UNPACK #-} !Word16-    , _nrLength             :: {-# UNPACK #-} !Word16-    , _nrOffset             :: {-# UNPACK #-} !Word16-    , _nrString             :: !B.ByteString-    }-    deriving Show--fontFamilyName :: NameTable -> T.Text-fontFamilyName (NameTable { _ntRecords = records }) =-    fromMaybe T.empty . asum $ transform <$>-            [ (selectorUnicode, utf16Decoder)-            , (selectorMac, utf8Decoder)-            , (selectorWin0, utf16Decoder)-            , (selectorWin1, utf16Decoder)-            ]-  where-    utf16Decoder = TE.decodeUtf16BE . _nrString-    utf8Decoder = TE.decodeUtf8 . _nrString-    transform (selector, decoder) =-        decoder <$> V.find selector records--    fontFamilyId = 1--    windowsPlatform =-        platformToWord PlatformWindows-    selectorWin0 r =-                  _nrNameId r == fontFamilyId &&-      _nrPlatoformId r        == windowsPlatform &&-      _nrPlatformSpecificId r == 0--    selectorWin1 r =-                  _nrNameId r == fontFamilyId &&-      _nrPlatoformId r        == windowsPlatform &&-      _nrPlatformSpecificId r == 1--    macPlatform =-        platformToWord PlatformMacintosh-    selectorMac r =-                  _nrNameId r == fontFamilyId &&-      _nrPlatoformId r        == macPlatform &&-      _nrPlatformSpecificId r == 0--    unicodePlatform =-        platformToWord PlatformUnicode-    semanticUnicode2 =-        unicodePlatformSpecificToId UnicodeBMPOnly2_0-    selectorUnicode r =-                  _nrNameId r == fontFamilyId &&-      _nrPlatoformId r        == unicodePlatform &&-      _nrPlatformSpecificId r == semanticUnicode2--instance Binary NameRecords where-  get = NameRecords <$> g16 <*> g16 <*> g16 -                    <*> g16 <*> g16 <*> g16 -                    <*> pure mempty-      where g16 = getWord16be--  put (NameRecords p ps l n len ofs _) =-      p16 p >> p16 ps >> p16 l >> p16 n >> p16 len >> p16 ofs-    where p16 = putWord16be--+{-# LANGUAGE CPP #-}
+module Graphics.Text.TrueType.Name
+    ( NameTable
+    , NameRecords
+    , fontFamilyName
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid( mempty )
+import Control.Applicative( (<$>), (<*>), pure )
+#endif
+
+import Control.DeepSeq( NFData( .. ) )
+import Control.Monad( when, replicateM )
+import Data.Foldable( asum )
+import Data.Function( on )
+import Data.List( maximumBy )
+import Data.Maybe( fromMaybe )
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( getWord16be, getByteString )
+import Data.Binary.Put( putWord16be )
+import Data.Word( Word16 )
+import qualified Data.Vector as V
+import qualified Data.ByteString as B
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+
+import Graphics.Text.TrueType.LanguageIds
+
+data NameTable = NameTable
+    { _ntRecords      :: !(V.Vector NameRecords) }
+    deriving Show
+
+instance NFData NameTable where
+    rnf (NameTable {}) = ()
+
+instance Binary NameTable where
+  put _ = fail "Binary.put NameTable - unimplemented"
+  get = do
+    nameFormatId <- getWord16be
+    when (nameFormatId /= 0) $
+          fail "Invalid name table format"
+    count <- getWord16be
+    stringOffset <- getWord16be
+    records <- replicateM (fromIntegral count) get
+    let maxRec = maximumBy (compare `on` _nrOffset) records
+        toFetch = fromIntegral (_nrOffset maxRec) + fromIntegral (_nrLength maxRec)
+                - fromIntegral stringOffset
+
+    strTable <- getByteString toFetch
+    let fetcher r = r { _nrString = B.take iLength $ B.drop iOffset strTable }
+          where iLength = fromIntegral $ _nrLength r
+                iOffset = fromIntegral $ _nrOffset r
+
+    return . NameTable . V.fromListN (fromIntegral count) $ map fetcher records
+
+data NameRecords = NameRecords
+    { _nrPlatoformId        :: {-# UNPACK #-} !Word16
+    , _nrPlatformSpecificId :: {-# UNPACK #-} !Word16
+    , _nrLanguageId         :: {-# UNPACK #-} !Word16
+    , _nrNameId             :: {-# UNPACK #-} !Word16
+    , _nrLength             :: {-# UNPACK #-} !Word16
+    , _nrOffset             :: {-# UNPACK #-} !Word16
+    , _nrString             :: !B.ByteString
+    }
+    deriving Show
+
+fontFamilyName :: NameTable -> T.Text
+fontFamilyName (NameTable { _ntRecords = records }) =
+    fromMaybe T.empty . asum $ transform <$>
+            [ (selectorUnicode, utf16Decoder)
+            , (selectorMac, utf8Decoder)
+            , (selectorWin0, utf16Decoder)
+            , (selectorWin1, utf16Decoder)
+            ]
+  where
+    utf16Decoder = TE.decodeUtf16BE . _nrString
+    utf8Decoder = TE.decodeUtf8 . _nrString
+    transform (selector, decoder) =
+        decoder <$> V.find selector records
+
+    fontFamilyId = 1
+
+    windowsPlatform =
+        platformToWord PlatformWindows
+    selectorWin0 r =
+                  _nrNameId r == fontFamilyId &&
+      _nrPlatoformId r        == windowsPlatform &&
+      _nrPlatformSpecificId r == 0
+
+    selectorWin1 r =
+                  _nrNameId r == fontFamilyId &&
+      _nrPlatoformId r        == windowsPlatform &&
+      _nrPlatformSpecificId r == 1
+
+    macPlatform =
+        platformToWord PlatformMacintosh
+    selectorMac r =
+                  _nrNameId r == fontFamilyId &&
+      _nrPlatoformId r        == macPlatform &&
+      _nrPlatformSpecificId r == 0
+
+    unicodePlatform =
+        platformToWord PlatformUnicode
+    semanticUnicode2 =
+        unicodePlatformSpecificToId UnicodeBMPOnly2_0
+    selectorUnicode r =
+                  _nrNameId r == fontFamilyId &&
+      _nrPlatoformId r        == unicodePlatform &&
+      _nrPlatformSpecificId r == semanticUnicode2
+
+instance Binary NameRecords where
+  get = NameRecords <$> g16 <*> g16 <*> g16 
+                    <*> g16 <*> g16 <*> g16 
+                    <*> pure mempty
+      where g16 = getWord16be
+
+  put (NameRecords p ps l n len ofs _) =
+      p16 p >> p16 ps >> p16 l >> p16 n >> p16 len >> p16 ofs
+    where p16 = putWord16be
+
+

src/Graphics/Text/TrueType/OffsetTable.hs view

@@ -1,89 +1,89 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.OffsetTable-    ( OffsetTableHeader( .. )-    , OffsetTable( .. )-    , TableDirectoryEntry( .. )-    , filterTable-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<*>), (<$>) )-#endif--import Data.Word( Word16, Word32 )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( getWord16be-                      , getWord32be-                      , getByteString-                      )--import Data.Binary.Put( putWord16be-                      , putWord32be-                      , putByteString-                      )--import qualified Data.Vector as V-import qualified Data.ByteString.Char8 as BC--import Graphics.Text.TrueType.Types--data OffsetTableHeader = OffsetTableHeader-    { -- | sfnt version 0x00010000 for version 1.0.-      _othSfntVersion   :: !Fixed-      -- | numTables Number of tables.-    , _othTableCount    :: !Word16-      -- | searchRange (Maximum power of 2 ? numTables) x 16.-    , _othSearchRange   :: !Word16-      -- | entrySelector Log2(maximum power of 2 ? numTables).-    , _othEntrySelector :: !Word16-      -- | rangeShift NumTables x 16-searchRange.-    , _othRangeShift    :: !Word16-    }-    deriving (Eq, Show)--instance Binary OffsetTableHeader where-  get = OffsetTableHeader <$> get <*> g16 <*> g16 <*> g16 <*> g16-    where g16 = getWord16be-  put (OffsetTableHeader ver c sr es rs) =-    put ver >> p16 c >> p16 sr >> p16 es >> p16 rs-      where p16 = putWord16be--data TableDirectoryEntry = TableDirectoryEntry-    { -- | tag 4 -byte identifier.-      _tdeTag      :: !BC.ByteString-      -- | CheckSum for this table.-    , _tdeChecksum :: !Word32-      -- | Offset from beginning of TrueType font file.-    , _tdeOffset   :: !Word32-      -- | Length of this table.-    , _tdeLength   :: !Word32-    }-    deriving (Eq, Show)--filterTable :: (BC.ByteString -> Bool) -> OffsetTable-            -> OffsetTable-filterTable f table =-  table { _otEntries = V.filter (f . _tdeTag) $ _otEntries table }--instance Binary TableDirectoryEntry where-  get = TableDirectoryEntry <$> getByteString 4 <*> g32 <*> g32 <*> g32-    where g32 = getWord32be-  put (TableDirectoryEntry tag chk offset ln) =-      putByteString tag >> p32 chk >> p32 offset >> p32 ln-        where p32 = putWord32be--data OffsetTable = OffsetTable-    { _otHeader  :: !OffsetTableHeader-    , _otEntries :: !(V.Vector TableDirectoryEntry)-    }-    deriving (Eq, Show)--instance Binary OffsetTable where-    put (OffsetTable hdr entries) =-        put hdr >> V.forM_ entries put--    get = do-        hdr <- get-        let count = fromIntegral $ _othTableCount hdr-        OffsetTable hdr <$> V.replicateM count get-+{-# LANGUAGE CPP #-}
+module Graphics.Text.TrueType.OffsetTable
+    ( OffsetTableHeader( .. )
+    , OffsetTable( .. )
+    , TableDirectoryEntry( .. )
+    , filterTable
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<*>), (<$>) )
+#endif
+
+import Data.Word( Word16, Word32 )
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( getWord16be
+                      , getWord32be
+                      , getByteString
+                      )
+
+import Data.Binary.Put( putWord16be
+                      , putWord32be
+                      , putByteString
+                      )
+
+import qualified Data.Vector as V
+import qualified Data.ByteString.Char8 as BC
+
+import Graphics.Text.TrueType.Types
+
+data OffsetTableHeader = OffsetTableHeader
+    { -- | sfnt version 0x00010000 for version 1.0.
+      _othSfntVersion   :: !Fixed
+      -- | numTables Number of tables.
+    , _othTableCount    :: !Word16
+      -- | searchRange (Maximum power of 2 ? numTables) x 16.
+    , _othSearchRange   :: !Word16
+      -- | entrySelector Log2(maximum power of 2 ? numTables).
+    , _othEntrySelector :: !Word16
+      -- | rangeShift NumTables x 16-searchRange.
+    , _othRangeShift    :: !Word16
+    }
+    deriving (Eq, Show)
+
+instance Binary OffsetTableHeader where
+  get = OffsetTableHeader <$> get <*> g16 <*> g16 <*> g16 <*> g16
+    where g16 = getWord16be
+  put (OffsetTableHeader ver c sr es rs) =
+    put ver >> p16 c >> p16 sr >> p16 es >> p16 rs
+      where p16 = putWord16be
+
+data TableDirectoryEntry = TableDirectoryEntry
+    { -- | tag 4 -byte identifier.
+      _tdeTag      :: !BC.ByteString
+      -- | CheckSum for this table.
+    , _tdeChecksum :: !Word32
+      -- | Offset from beginning of TrueType font file.
+    , _tdeOffset   :: !Word32
+      -- | Length of this table.
+    , _tdeLength   :: !Word32
+    }
+    deriving (Eq, Show)
+
+filterTable :: (BC.ByteString -> Bool) -> OffsetTable
+            -> OffsetTable
+filterTable f table =
+  table { _otEntries = V.filter (f . _tdeTag) $ _otEntries table }
+
+instance Binary TableDirectoryEntry where
+  get = TableDirectoryEntry <$> getByteString 4 <*> g32 <*> g32 <*> g32
+    where g32 = getWord32be
+  put (TableDirectoryEntry tag chk offset ln) =
+      putByteString tag >> p32 chk >> p32 offset >> p32 ln
+        where p32 = putWord32be
+
+data OffsetTable = OffsetTable
+    { _otHeader  :: !OffsetTableHeader
+    , _otEntries :: !(V.Vector TableDirectoryEntry)
+    }
+    deriving (Eq, Show)
+
+instance Binary OffsetTable where
+    put (OffsetTable hdr entries) =
+        put hdr >> V.forM_ entries put
+
+    get = do
+        hdr <- get
+        let count = fromIntegral $ _othTableCount hdr
+        OffsetTable hdr <$> V.replicateM count get
+

src/Graphics/Text/TrueType/Types.hs view

@@ -1,48 +1,48 @@-{-# LANGUAGE CPP #-}-module Graphics.Text.TrueType.Types-    ( Fixed( .. )-    , FWord( .. )-    , F26Dot6( .. )-    ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>), (<*>) )-#endif--import Data.Int( Int32 )-import Data.Word( Word16 )-import Data.Binary( Binary( .. ) )-import Data.Binary.Get( getWord16be)-import Data.Binary.Put( putWord16be )--data Fixed = Fixed Word16 Word16-    deriving (Eq, Show)--instance Binary Fixed where-    get = Fixed <$> getWord16be <*> getWord16be-    put (Fixed a b) = putWord16be a >> putWord16be b--newtype FWord = FWord Word16-    deriving (Eq, Show)--instance Binary FWord where-  put (FWord w) = putWord16be w-  get = FWord <$> getWord16be--newtype F26Dot6 = F26Dot6 Int32-    deriving (Eq, Show, Ord)--instance Num F26Dot6 where-    (F26Dot6 a) + (F26Dot6 b) = F26Dot6 $ a + b-    (F26Dot6 a) - (F26Dot6 b) = F26Dot6 $ a - b-    (F26Dot6 a) * (F26Dot6 b) = F26Dot6 $ (a * b) `div` 64-    negate (F26Dot6 a) = F26Dot6 $ negate a-    abs (F26Dot6 a) = F26Dot6 $ abs a-    signum (F26Dot6 a) = F26Dot6 $ signum a * 64-    fromInteger a = F26Dot6 $ fromInteger a * 64--instance Fractional F26Dot6 where-    fromRational a = F26Dot6 $ floor ad-      where ad = fromRational a * 64 :: Double-    (F26Dot6 a) / (F26Dot6 b) = F26Dot6 $ (a * 64) `div` b-+{-# LANGUAGE CPP #-}
+module Graphics.Text.TrueType.Types
+    ( Fixed( .. )
+    , FWord( .. )
+    , F26Dot6( .. )
+    ) where
+
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative( (<$>), (<*>) )
+#endif
+
+import Data.Int( Int32 )
+import Data.Word( Word16 )
+import Data.Binary( Binary( .. ) )
+import Data.Binary.Get( getWord16be)
+import Data.Binary.Put( putWord16be )
+
+data Fixed = Fixed Word16 Word16
+    deriving (Eq, Show)
+
+instance Binary Fixed where
+    get = Fixed <$> getWord16be <*> getWord16be
+    put (Fixed a b) = putWord16be a >> putWord16be b
+
+newtype FWord = FWord Word16
+    deriving (Eq, Show)
+
+instance Binary FWord where
+  put (FWord w) = putWord16be w
+  get = FWord <$> getWord16be
+
+newtype F26Dot6 = F26Dot6 Int32
+    deriving (Eq, Show, Ord)
+
+instance Num F26Dot6 where
+    (F26Dot6 a) + (F26Dot6 b) = F26Dot6 $ a + b
+    (F26Dot6 a) - (F26Dot6 b) = F26Dot6 $ a - b
+    (F26Dot6 a) * (F26Dot6 b) = F26Dot6 $ (a * b) `div` 64
+    negate (F26Dot6 a) = F26Dot6 $ negate a
+    abs (F26Dot6 a) = F26Dot6 $ abs a
+    signum (F26Dot6 a) = F26Dot6 $ signum a * 64
+    fromInteger a = F26Dot6 $ fromInteger a * 64
+
+instance Fractional F26Dot6 where
+    fromRational a = F26Dot6 $ floor ad
+      where ad = fromRational a * 64 :: Double
+    (F26Dot6 a) / (F26Dot6 b) = F26Dot6 $ (a * 64) `div` b
+