packages feed

gelatin-freetype2 (empty) → 0.1.0.0

raw patch · 7 files changed

+635/−0 lines, 7 filesdep +basedep +containersdep +eithersetup-changed

Dependencies added: base, containers, either, freetype2, gelatin, gelatin-freetype2, gelatin-gl, mtl, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Schell Scivally (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Schell Scivally nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gelatin-freetype2.cabal view
@@ -0,0 +1,67 @@+name:                gelatin-freetype2+version:             0.1.0.0+synopsis:            FreeType2 based text rendering for the gelatin realtime+                     rendering system.+description:         FreeType2 based text rendering for the gelatin realtime+                     rendering system. Please see README.md.+homepage:            https://github.com/schell/gelatin/gelatin-freetype2#readme+license:             BSD3+license-file:        LICENSE+author:              Schell Scivally+maintainer:          schell@zyghost.com+copyright:           Schell Scivally+category:            Web+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10+stability:           experimental++library+  hs-source-dirs:      src+  exposed-modules:     Gelatin.FreeType2.Internal+                     , Gelatin.FreeType2.Utils+                     , Gelatin.FreeType2++  build-depends:       base               >=4.8 && <4.11+                     , gelatin            >=0.1 && <0.2+                     , gelatin-gl         >=0.1 && <0.2+                     , freetype2          >=0.1 && <0.2+                     , transformers       >=0.4 && <0.6+                     , mtl                >=2.2 && <2.3+                     , containers         >=0.5 && <0.6+                     , either             >=4.4 && <4.6++  default-language:    Haskell2010++--executable gelatin-freetype2-exe+--  hs-source-dirs:      app+--  main-is:             Main.hs+--  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N+--  build-depends:       base >=4.8 && <4.11+--                     , gelatin+--                     , gelatin-freetype2+--                     , gelatin-sdl2+--                     , gelatin-gl+--                     , freetype2+--                     , sdl2+--                     , halive+--                     , transformers+--                     , mtl+--                     , containers+--                     , pretty-show+--                     , vector+--+--  default-language:    Haskell2010++test-suite gelatin-freetype2-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base                  >=4.8 && <4.11+                     , gelatin-freetype2+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/schell/gelatin-freetype2
+ src/Gelatin/FreeType2.hs view
@@ -0,0 +1,30 @@+-- |+-- Module:     Gelatin.GL+-- Copyright:  (c) 2017 Schell Scivally+-- License:    MIT+-- Maintainer: Schell Scivally <schell@takt.com>+--+-- This module provides font string rendering through the legendary freetype2.+-- It automatically manages a texture atlas and word atlas to speed up rendering.+module Gelatin.FreeType2+  (-- * Getting straight to rendering+    freetypeRenderer2+    -- * Creating a gelatin picture+  , freetypePicture+    -- * Creating an Atlas+  , allocAtlas+  , asciiChars+  , freeAtlas+  , loadWords+  , unloadMissingWords+  , Atlas(..)+    -- * Going deeper+    -- ** Glyphs+  , GlyphSize(..)+  , glyphWidth+  , glyphHeight+    -- ** Measuring glyphs+  , GlyphMetrics(..)+  ) where++import Gelatin.FreeType2.Internal
+ src/Gelatin/FreeType2/Internal.hs view
@@ -0,0 +1,381 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+-- |+-- Module:     Gelatin.FreeType2+-- Copyright:  (c) 2017 Schell Scivally+-- License:    MIT+-- Maintainer: Schell Scivally <schell@takt.com>+--+-- This module provides easy freetype2 font rendering using gelatin's+-- graphics primitives.+--+module Gelatin.FreeType2.Internal where++import           Gelatin.GL+import           Gelatin.FreeType2.Utils+import           Gelatin.Picture.Internal+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.State.Strict+import           Data.Maybe (fromMaybe)+import           Data.IntMap (IntMap)+import qualified Data.IntMap as IM+import           Data.Map (Map)+import qualified Data.Map as M+import           Foreign.Marshal.Utils (with)+import           Graphics.Rendering.FreeType.Internal.GlyphMetrics as GM+import           Graphics.Rendering.FreeType.Internal.Bitmap as BM+--------------------------------------------------------------------------------+-- WordMap+--------------------------------------------------------------------------------+type WordMap = Map String (V2 Float, Renderer2)++-- | Load a string of words into the 'Atlas'.+loadWords+  :: MonadIO m+  => Backend GLuint e V2V2 (V2 Float) Float Raster+  -- ^ The V2V2 backend needed to render font glyphs.+  -> Atlas+  -- ^ The atlas to load the words into.+  -> String+  -- ^ The string of words to load, with each word separated by spaces.+  -> m Atlas+loadWords b atlas str = do+  wm <- liftIO $ foldM loadWord (atlasWordMap atlas) $ words str+  return atlas{atlasWordMap=wm}+  where loadWord wm word+          | Just _ <- M.lookup word wm = return wm+          | otherwise = do+              let pic = do freetypePicture atlas word+                           pictureSize2 fst+              (sz,r) <- compilePictureT b pic+              return $ M.insert word (sz,r) wm++-- | Unload any words not contained in the source string.+unloadMissingWords+  :: MonadIO m+  => Atlas+  -- ^ The 'Atlas' to unload words from.+  -> String+  -- ^ The source string.+  -> m Atlas+unloadMissingWords atlas str = do+  let wm = atlasWordMap atlas+      ws = M.fromList $ zip (words str) [(0::Int)..]+      missing = M.difference wm ws+      retain  = M.difference wm missing+      dealoc  = (liftIO . fst . snd) <$> missing+  sequence_ dealoc+  return atlas{atlasWordMap=retain}+--------------------------------------------------------------------------------+-- Glyph+--------------------------------------------------------------------------------+data GlyphSize = CharSize Float Float Int Int+               | PixelSize Int Int+               deriving (Show, Eq, Ord)++glyphWidth :: GlyphSize -> Float+glyphWidth (CharSize x y _ _) = if x == 0 then y else x+glyphWidth (PixelSize x y) = fromIntegral $ if x == 0 then y else x++glyphHeight :: GlyphSize -> Float+glyphHeight (CharSize x y _ _) = if y == 0 then x else y+glyphHeight (PixelSize x y) = fromIntegral $ if y == 0 then x else y++-- | https://www.freetype.org/freetype2/docs/tutorial/step2.html+data GlyphMetrics = GlyphMetrics { glyphTexBB       :: (V2 Int, V2 Int)+                                 , glyphTexSize     :: V2 Int+                                 , glyphSize        :: V2 Int+                                 , glyphHoriBearing :: V2 Int+                                 , glyphVertBearing :: V2 Int+                                 , glyphAdvance     :: V2 Int+                                 } deriving (Show, Eq)+--------------------------------------------------------------------------------+-- Atlas+--------------------------------------------------------------------------------+data Atlas = Atlas { atlasTexture     :: GLuint+                   , atlasTextureSize :: V2 Int+                   , atlasLibrary     :: FT_Library+                   , atlasFontFace    :: FT_Face+                   , atlasMetrics     :: IntMap GlyphMetrics+                   , atlasGlyphSize   :: GlyphSize+                   , atlasWordMap     :: WordMap+                   , atlasFilePath    :: FilePath+                   }++emptyAtlas :: FT_Library -> FT_Face -> GLuint -> Atlas+emptyAtlas lib face t = Atlas t 0 lib face mempty (PixelSize 0 0) mempty ""++data AtlasMeasure = AM { amWH :: V2 Int+                       , amXY :: V2 Int+                       , rowHeight :: Int+                       , amMap :: IntMap (V2 Int)+                       } deriving (Show, Eq)++emptyAM :: AtlasMeasure+emptyAM = AM 0 (V2 1 1) 0 mempty++spacing :: Int+spacing = 1++measure :: FT_Face -> Int -> AtlasMeasure -> Char -> FreeTypeIO AtlasMeasure+measure face maxw am@AM{..} char+  | Just _ <- IM.lookup (fromEnum char) amMap = return am+  | otherwise = do+    let V2 x y = amXY+        V2 w h = amWH+    -- Load the char, replacing the glyph according to+    -- https://www.freetype.org/freetype2/docs/tutorial/step1.html+    loadChar face (fromIntegral $ fromEnum char) ft_LOAD_RENDER+    -- Get the glyph slot+    slot <- liftIO $ peek $ glyph face+    -- Get the bitmap+    bmp   <- liftIO $ peek $ bitmap slot+    let bw = fromIntegral $ BM.width bmp+        bh = fromIntegral $ rows bmp+        gotoNextRow = (x + bw + spacing) >= maxw+        rh = if gotoNextRow then 0 else max bh rowHeight+        nx = if gotoNextRow then 0 else x + bw + spacing+        nw = max w (x + bw + spacing)+        nh = max h (y + rh + spacing)+        ny = if gotoNextRow then nh else y+        am = AM { amWH = V2 nw nh+                , amXY = V2 nx ny+                , rowHeight = rh+                , amMap = IM.insert (fromEnum char) amXY amMap+                }+    return am++texturize :: IntMap (V2 Int) -> Atlas -> Char -> FreeTypeIO Atlas+texturize xymap atlas@Atlas{..} char+  | Just pos@(V2 x y) <- IM.lookup (fromEnum char) xymap = do+    -- Load the char+    loadChar atlasFontFace (fromIntegral $ fromEnum char) ft_LOAD_RENDER+    -- Get the slot and bitmap+    slot  <- liftIO $ peek $ glyph atlasFontFace+    bmp   <- liftIO $ peek $ bitmap slot+    -- Update our texture by adding the bitmap+    glTexSubImage2D GL_TEXTURE_2D 0+                    (fromIntegral x) (fromIntegral y)+                    (fromIntegral $ BM.width bmp) (fromIntegral $ rows bmp)+                    GL_RED GL_UNSIGNED_BYTE+                    (castPtr $ buffer bmp)+    -- Get the glyph metrics+    ftms  <- liftIO $ peek $ metrics slot+    -- Add the metrics to the atlas+    let vecwh = fromIntegral <$> V2 (BM.width bmp) (rows bmp)+        canon = floor . (* 0.5) . (* 0.015625) . realToFrac . fromIntegral+        vecsz = canon <$> V2 (GM.width ftms) (GM.height ftms)+        vecxb = canon <$> V2 (horiBearingX ftms) (horiBearingY ftms)+        vecyb = canon <$> V2 (vertBearingX ftms) (vertBearingY ftms)+        vecad = canon <$> V2 (horiAdvance ftms) (vertAdvance ftms)+        mtrcs = GlyphMetrics { glyphTexBB = (pos, pos + vecwh)+                             , glyphTexSize = vecwh+                             , glyphSize = vecsz+                             , glyphHoriBearing = vecxb+                             , glyphVertBearing = vecyb+                             , glyphAdvance = vecad+                             }+    return atlas{ atlasMetrics = IM.insert (fromEnum char) mtrcs atlasMetrics }++  | otherwise = do+    liftIO $ putStrLn "could not find xy"+    return atlas++-- | Allocate a new 'Atlas'.+-- When creating a new 'Atlas' you must pass all the characters that you+-- might need during the life of the 'Atlas'. Character texturization only+-- happens here.+allocAtlas+  :: MonadIO m+  => FilePath+  -- ^ 'FilePath' of the 'Font' to use for this 'Atlas'.+  -> GlyphSize+  -- ^ Size of glyphs in this 'Atlas'+  -> String+  -- ^ The characters to include in this 'Atlas'.+  -> m (Maybe Atlas)+allocAtlas fontFilePath gs str = do+  e <- liftIO $ runFreeType $ do+    fce <- newFace fontFilePath+    case gs of+      PixelSize w h -> setPixelSizes fce (2*w) (2*h)+      CharSize w h dpix dpiy -> setCharSize fce (floor $ 26.6 * 2 * w)+                                                (floor $ 26.6 * 2 * h)+                                                dpix dpiy++    AM{..} <- foldM (measure fce 512) emptyAM str++    let V2 w h = amWH+        xymap  = amMap++    t <- liftIO $ do+      t <- allocAndActivateTex GL_TEXTURE0+      glPixelStorei GL_UNPACK_ALIGNMENT 1+      withCString (replicate (w * h) $ toEnum 0) $+        glTexImage2D GL_TEXTURE_2D 0 GL_RED (fromIntegral w) (fromIntegral h)+                     0 GL_RED GL_UNSIGNED_BYTE . castPtr+      return t++    lib   <- getLibrary+    atlas <- foldM (texturize xymap) (emptyAtlas lib fce t) str++    glGenerateMipmap GL_TEXTURE_2D+    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT+    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT+    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR+    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR+    glBindTexture GL_TEXTURE_2D 0+    glPixelStorei GL_UNPACK_ALIGNMENT 4+    return+      atlas{ atlasTextureSize = V2 w h+           , atlasGlyphSize = gs+           , atlasFilePath = fontFilePath+           }+  case e of+    Left err -> liftIO (print err) >> return Nothing+    Right (atlas,_) -> return $ Just atlas++-- | Releases all resources associated with the given 'Atlas'.+freeAtlas :: MonadIO m => Atlas -> m ()+freeAtlas a = liftIO $ do+  _ <- ft_Done_FreeType (atlasLibrary a)+  _ <- unloadMissingWords a ""+  with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr++makeCharQuad :: MonadIO m => Atlas -> Bool -> (Int, Maybe FT_UInt) -> Char+             -> VerticesT (V2 Float, V2 Float) m (Int, Maybe FT_UInt)+makeCharQuad Atlas{..} useKerning (penx, mLast) char = do+  let ichar = fromEnum char+  eNdx <- withFreeType (Just atlasLibrary) $ getCharIndex atlasFontFace ichar+  let mndx = either (const Nothing) Just eNdx+  px <- case (,,) <$> mndx <*> mLast <*> Just useKerning of+    Just (ndx,lndx,True) -> do+      e <- withFreeType (Just atlasLibrary) $+        getKerning atlasFontFace lndx ndx ft_KERNING_DEFAULT+      return $ either (const penx) ((+penx) . floor . (/(64::Double)) . fromIntegral . fst) e+    _  -> return $ fromIntegral penx+  case IM.lookup ichar atlasMetrics of+    Nothing -> return (penx, mndx)+    Just GlyphMetrics{..} -> do+      let V2 dx dy = fromIntegral <$> glyphHoriBearing+          x = (fromIntegral px) + dx+          y = -dy+          V2 w h = fromIntegral <$> glyphSize+          V2 aszW aszH = fromIntegral <$> atlasTextureSize+          V2 texL texT = fromIntegral <$> fst glyphTexBB+          V2 texR texB = fromIntegral <$> snd glyphTexBB++          tl = (V2 (x)    y   , V2 (texL/aszW) (texT/aszH))+          tr = (V2 (x+w)  y   , V2 (texR/aszW) (texT/aszH))+          br = (V2 (x+w) (y+h), V2 (texR/aszW) (texB/aszH))+          bl = (V2 (x)   (y+h), V2 (texL/aszW) (texB/aszH))+      tri tl tr br+      tri tl br bl+      let V2 ax _ = glyphAdvance++      return (px + ax, mndx)++-- | A string containing all standard ASCII characters.+-- This is often passed as the 'String' parameter in 'allocAtlas'.+asciiChars :: String+asciiChars = map toEnum [32..126]++stringTris :: MonadIO m => Atlas -> Bool -> String -> VerticesT (V2 Float, V2 Float) m ()+stringTris atlas useKerning =+  foldM_ (makeCharQuad atlas useKerning) (0, Nothing)+--------------------------------------------------------------------------------+-- Picture+--------------------------------------------------------------------------------+-- | Constructs a 'TexturePictureT' of one word in all red.+-- Colorization can then be done using 'setReplacementColor' in the picture+-- computation, or by using 'redChannelReplacement' and passing that to the+-- renderer after compilation, at render time. Keep in mind that any new word+-- geometry will be discarded, since this computation does not return a new 'Atlas'.+-- For that reason it is advised that you load the needed words before using this+-- function. For loading words, see 'loadWords'.+--+-- This is used in 'freetypeRenderer2' to construct the geometry of each word.+-- 'freetypeRenderer2' goes further and stores these geometries, looking them up+-- and constructing a string of word renderers for each input 'String'.+freetypePicture+  :: MonadIO m+  => Atlas+  -- ^ The 'Atlas' from which to read font textures word geometry.+  -> String+  -- ^ The word to render.+  -> TexturePictureT m ()+  -- ^ Returns a textured picture computation representing the texture and+  -- geometry of the input word.+freetypePicture atlas@Atlas{..} str = do+  eKerning <- withFreeType (Just atlasLibrary) $ hasKerning atlasFontFace+  setTextures [atlasTexture]+  let useKerning = either (const False) id eKerning+  setGeometry $ triangles $ stringTris atlas useKerning str+--------------------------------------------------------------------------------+-- Performance Rendering+--------------------------------------------------------------------------------+-- | Constructs a 'Renderer2' from the given color and string. The 'WordMap'+-- record of the given 'Atlas' is used to construct the string geometry, greatly+-- improving performance and allowing longer strings to be compiled and renderered+-- in real time. To create a new 'Atlas' see 'allocAtlas'.+--+-- Note that since word geometries are stored in the 'Atlas' 'WordMap' and multiple+-- renderers can reference the same 'Atlas', the returned 'Renderer2' contains a+-- clean up operation that does nothing. It is expected that the programmer+-- will call 'freeAtlas' manually when the 'Atlas' is no longer needed.+freetypeRenderer2+  :: MonadIO m+  => Backend GLuint e V2V2 (V2 Float) Float Raster+  -- ^ The V2V2 backend to use for compilation.+  -> Atlas+  -- ^ The 'Atlas' to read character textures from and load word geometry+  -- into.+  -> V4 Float+  -- ^ The solid color to render the string with.+  -> String+  -- ^ The string to render.+  -- This string can contain newlines, which will be respected.+  -> m (Renderer2, V2 Float, Atlas)+  -- ^ Returns the 'Renderer2', the size of the text and the new+  -- 'Atlas' with the loaded geometry of the string.+freetypeRenderer2 b atlas0 color str = do+  atlas <- loadWords b atlas0 str+  let glyphw  = glyphWidth $ atlasGlyphSize atlas+      spacew  = fromMaybe glyphw $ do+        metrcs <- IM.lookup (fromEnum ' ') $ atlasMetrics atlas+        let V2 x _ = glyphAdvance metrcs+        return $ fromIntegral x+      glyphh = glyphHeight $ atlasGlyphSize atlas+      spaceh = glyphh+      isWhiteSpace c = c == ' ' || c == '\n' || c == '\t'+      renderWord :: [RenderTransform2] -> V2 Float -> String -> IO ()+      renderWord _ _ ""       = return ()+      renderWord rs (V2 _ y) ('\n':cs) = renderWord rs (V2 0 (y + spaceh)) cs+      renderWord rs (V2 x y) (' ':cs) = renderWord rs (V2 (x + spacew) y) cs+      renderWord rs (V2 x y) cs       = do+        let word = takeWhile (not . isWhiteSpace) cs+            rest = drop (length word) cs+        case M.lookup word (atlasWordMap atlas) of+          Nothing          -> renderWord rs (V2 x y) rest+          Just (V2 w _, r) -> do+            let ts = [move x y, redChannelReplacementV4 color]+            snd r $ ts ++ rs+            renderWord rs (V2 (x + w) y) rest+      rr t = renderWord t 0 str+      measureString :: (V2 Float, V2 Float) -> String -> (V2 Float, V2 Float)+      measureString (V2 x y, V2 w h) ""        = (V2 x y, V2 w h)+      measureString (V2 x y, V2 w _) (' ':cs)  =+        let nx = x + spacew in measureString (V2 nx y, V2 (max w nx) y) cs+      measureString (V2 x y, V2 w h) ('\n':cs) =+        let ny = y + spaceh in measureString (V2 x ny, V2 w (max h ny)) cs+      measureString (V2 x y, V2 w h) cs        =+        let word = takeWhile (not . isWhiteSpace) cs+            rest = drop (length word) cs+            n    = case M.lookup word (atlasWordMap atlas) of+                     Nothing          -> (V2 x y, V2 w h)+                     Just (V2 ww _, _) -> let nx = x + ww+                                          in (V2 nx y, V2 (max w nx) y)+        in measureString n rest+      V2 szw szh = snd $ measureString (0,0) str+  return ((return (), rr), V2 szw (max spaceh szh), atlas)
+ src/Gelatin/FreeType2/Utils.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}+module Gelatin.FreeType2.Utils (+   module FT+ , FreeTypeT+ , FreeTypeIO+ , getAdvance+ , getCharIndex+ , getLibrary+ , getKerning+ , glyphFormatString+ , hasKerning+ , loadChar+ , loadGlyph+ , newFace+ , setCharSize+ , setPixelSizes+ , withFreeType+ , runFreeType+) where++import           Control.Monad.IO.Class (MonadIO, liftIO)+import           Control.Monad.Trans.Either+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.State.Strict+import           Control.Monad (unless)+import           Graphics.Rendering.FreeType.Internal                   as FT+import           Graphics.Rendering.FreeType.Internal.PrimitiveTypes    as FT+import           Graphics.Rendering.FreeType.Internal.Library           as FT+import           Graphics.Rendering.FreeType.Internal.FaceType          as FT+import           Graphics.Rendering.FreeType.Internal.Face as FT hiding (generic)+import           Graphics.Rendering.FreeType.Internal.GlyphSlot         as FT+import           Graphics.Rendering.FreeType.Internal.Bitmap            as FT+import           Graphics.Rendering.FreeType.Internal.Vector            as FT+import           Foreign                                                as FT+import           Foreign.C.String                                       as FT++type FreeTypeT m = EitherT String (StateT FT_Library m)+type FreeTypeIO = FreeTypeT IO++glyphFormatString :: FT_Glyph_Format -> String+glyphFormatString fmt+    | fmt == ft_GLYPH_FORMAT_COMPOSITE = "ft_GLYPH_FORMAT_COMPOSITE"+    | fmt == ft_GLYPH_FORMAT_OUTLINE = "ft_GLYPH_FORMAT_OUTLINE"+    | fmt == ft_GLYPH_FORMAT_PLOTTER = "ft_GLYPH_FORMAT_PLOTTER"+    | fmt == ft_GLYPH_FORMAT_BITMAP = "ft_GLYPH_FORMAT_BITMAP"+    | otherwise = "ft_GLYPH_FORMAT_NONE"++liftE :: MonadIO m => IO (Either FT_Error a) -> FreeTypeT m a+liftE f = (liftIO f) >>= \case+  Left e  -> left $ "FreeType2 error:" ++ (show e)+  Right a -> right a++runIOErr :: MonadIO m => IO FT_Error -> FreeTypeT m ()+runIOErr f = do+  e <- liftIO f+  unless (e == 0) $ fail $ "FreeType2 error:" ++ (show e)++runFreeType :: MonadIO m => FreeTypeT m a -> m (Either String (a, FT_Library))+runFreeType f = do+  (e,lib) <- liftIO $ alloca $ \p -> do+    e <- ft_Init_FreeType p+    lib <- peek p+    return (e,lib)+  if e /= 0+    then do+      _ <- liftIO $ ft_Done_FreeType lib+      return $ Left $ "Error initializing FreeType2:" ++ show e+    else (fmap (,lib)) <$> evalStateT (runEitherT f) lib++withFreeType :: MonadIO m => Maybe FT_Library -> FreeTypeT m a -> m (Either String a)+withFreeType Nothing f = runFreeType f >>= \case+  Left e -> return $ Left e+  Right (a,lib) -> do+    _ <- liftIO $ ft_Done_FreeType lib+    return $ Right a+withFreeType (Just lib) f = evalStateT (runEitherT f) lib++getLibrary :: MonadIO m => FreeTypeT m FT_Library+getLibrary = lift get++newFace :: MonadIO m => FilePath -> FreeTypeT m FT_Face+newFace fp = do+  ft <- lift get+  liftE $ withCString fp $ \str ->+    alloca $ \ptr -> ft_New_Face ft str 0 ptr >>= \case+      0 -> Right <$> peek ptr+      e -> return $ Left e++setCharSize :: (MonadIO m, Integral i) => FT_Face -> i -> i -> i -> i -> FreeTypeT m ()+setCharSize ff w h dpix dpiy = runIOErr $+  ft_Set_Char_Size ff (fromIntegral w)    (fromIntegral h)+                      (fromIntegral dpix) (fromIntegral dpiy)++setPixelSizes :: (MonadIO m, Integral i) => FT_Face -> i -> i -> FreeTypeT m ()+setPixelSizes ff w h =+  runIOErr $ ft_Set_Pixel_Sizes ff (fromIntegral w) (fromIntegral h)++getCharIndex :: (MonadIO m, Integral i)+             => FT_Face -> i -> FreeTypeT m FT_UInt+getCharIndex ff ndx = liftIO $ ft_Get_Char_Index ff $ fromIntegral ndx++loadGlyph :: MonadIO m => FT_Face -> FT_UInt -> FT_Int32 -> FreeTypeT m ()+loadGlyph ff fg flags = runIOErr $ ft_Load_Glyph ff fg flags++loadChar :: MonadIO m => FT_Face -> FT_ULong -> FT_Int32 -> FreeTypeT m ()+loadChar ff char flags = runIOErr $ ft_Load_Char ff char flags++hasKerning :: MonadIO m => FT_Face -> FreeTypeT m Bool+hasKerning = liftIO . ft_HAS_KERNING++getKerning :: MonadIO m => FT_Face -> FT_UInt -> FT_UInt -> FT_Kerning_Mode -> FreeTypeT m (Int,Int)+getKerning ff prevNdx curNdx flags = liftE $ alloca $ \ptr -> do+  ft_Get_Kerning ff prevNdx curNdx (fromIntegral flags) ptr >>= \case+    0 -> do FT_Vector x y <- peek ptr+            return $ Right (fromIntegral x, fromIntegral y)+    e -> return $ Left e++getAdvance :: MonadIO m => FT_GlyphSlot -> FreeTypeT m (Int,Int)+getAdvance slot = do+  FT_Vector x y <- liftIO $ peek $ advance slot+  liftIO $ print ("v",x,y)+  return (fromIntegral x, fromIntegral y)
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"