Loading fonts from memory

cbits/fontmanager.c

@@ -53,6 +53,14 @@ int fmCreateFont(FMcontext* ctx, const char* name, const char* filename)
 	return fonsAddFont(ctx->fs, name, filename, 0);
 }
 
+int fmCreateFontMem(FMcontext* ctx, const char* name, const char* data, int dataSize)
+{
+	// Pointer cast, as it was hard to create a Ptr CUChar in Haskell.
+	// Could be why it doesn't work.
+	const unsigned char* udata = data;
+	return fonsAddFontMem(ctx->fs, name, udata, dataSize, 1, 0);
+}
+
 void fmSetScale(FMcontext* ctx, float scale) {
 	ctx->scale = scale;
 }

cbits/fontmanager.h

@@ -39,6 +39,8 @@ FMcontext* fmInit(float dpr);
 
 int fmCreateFont(FMcontext* ctx, const char* name, const char* filename);
 
+int fmCreateFontMem(FMcontext* ctx, const char* name, const char* data, int dataSize);
+
 void fmSetScale(FMcontext* ctx, float scale);
 
 void fmFontFace(FMcontext* ctx, const char* font);

examples/todo/Main.hs

@@ -11,6 +11,7 @@ Main module for the 'Todo' example.
 {-# LANGUAGE BinaryLiterals #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Main where
 
@@ -26,6 +27,8 @@ import TodoTypes
 
 import qualified Monomer.Lens as L
 import qualified Data.Text as T
+import Data.FileEmbed (embedFile)
+import Monomer.Main.Types (appFontDefMem)
 
 type TodoWenv = WidgetEnv TodoModel TodoEvt
 type TodoNode = WidgetNode TodoModel TodoEvt
@@ -248,7 +251,7 @@ main = do
       appWindowIcon "./assets/images/icon.png",
       appTheme customDarkTheme,
       appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",
-      appFontDef "Medium" "./assets/fonts/Roboto-Medium.ttf",
+      appFontDefMem "Medium" $(embedFile "./assets/fonts/Roboto-Medium.ttf"),
       appFontDef "Bold" "./assets/fonts/Roboto-Bold.ttf",
       appFontDef "Remix" "./assets/fonts/remixicon.ttf",
       appInitEvent TodoInit

monomer.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.34.7.
 --
 -- see: https://github.com/sol/hpack
 
@@ -375,6 +375,7 @@ executable todo
     , data-default >=0.5 && <0.8
     , exceptions ==0.10.*
     , extra >=1.6 && <1.9
+    , file-embed
     , formatting >=6.0 && <8.0
     , http-client >=0.6 && <0.9
     , lens >=4.16 && <6

package.yaml

@@ -81,6 +81,7 @@ executables:
       - -threaded
     dependencies:
       - monomer
+      - file-embed
 
   books:
     main: Main.hs

src/Monomer/Graphics/FFI.chs

@@ -18,12 +18,13 @@ Based on code from cocreature's https://github.com/cocreature/nanovg-hs
 module Monomer.Graphics.FFI where
 
 import Control.Monad (forM)
-import Data.ByteString (useAsCString)
+import Data.ByteString (useAsCString, useAsCStringLen, ByteString)
+import Data.ByteString.Char8 (useAsCStringLen, unpack)
 import Data.Text (Text)
 import Data.Text.Foreign (withCStringLen)
 import Data.Sequence (Seq)
 import Foreign
-import Foreign.C (CString)
+import Foreign.C (CString, castCharToCUChar, newCAStringLen)
 import Foreign.C.Types
 import Foreign.Marshal.Alloc
 import Foreign.Ptr
@@ -118,6 +119,13 @@ withText t = useAsCString (T.encodeUtf8 t)
 withNull :: (Ptr a -> b) -> b
 withNull f = f nullPtr
 
+allocCAString :: ByteString -> ((Ptr CChar, CInt) -> IO a) -> IO a
+allocCAString bs continuation = do
+  -- not freeing the new string, as FMContext frees the fonts upon destruction
+  (ptr, len) <- newCAStringLen (unpack bs)
+  let args = (ptr, fromIntegral len)
+  continuation args
+
 -- Common
 {# pointer *FMcontext as FMContext newtype #}
 deriving instance Storable FMContext
@@ -126,6 +134,8 @@ deriving instance Storable FMContext
 
 {# fun unsafe fmCreateFont {`FMContext', withCString*`Text', withCString*`Text'} -> `Int' #}
 
+{# fun unsafe fmCreateFontMem {`FMContext', withCString*`Text', allocCAString*`ByteString'&} -> `Int' #}
+
 {# fun unsafe fmSetScale {`FMContext', `Double'} -> `()' #}
 
 {# fun unsafe fmFontFace {`FMContext', withCString*`Text'} -> `()' #}

src/Monomer/Graphics/FontManager.hs

@@ -29,6 +29,8 @@ import Monomer.Common.BasicTypes
 import Monomer.Graphics.FFI
 import Monomer.Graphics.Types
 import Monomer.Helper (putStrLnErr)
+import Control.Lens ((^.))
+import Monomer.Graphics.Lens (fontName, fontPath, fontBytes)
 
 -- | Creates a font manager instance.
 makeFontManager
@@ -101,11 +103,15 @@ newManager ctx = FontManager {..} where
       }
 
 loadFont :: FMContext -> [Text] -> FontDef -> IO [Text]
-loadFont ctx fonts (FontDef name path) = do
-  res <- fmCreateFont ctx name path
+loadFont ctx fonts fontDef = do
+  res <- createFont fontDef
   if res >= 0
-    then return $ path : fonts
+    then return $ name : fonts
     else putStrLnErr ("Failed to load font: " ++ T.unpack name) >> return fonts
+  where
+    name = fontDef ^. fontName
+    createFont FontDefFile{} = fmCreateFont ctx name (fontDef ^. fontPath)
+    createFont FontDefMem{} = fmCreateFontMem ctx name (fontDef ^. fontBytes)
 
 setFont :: FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
 setFont ctx scale (Font name) (FontSize size) (FontSpace spaceH) = do

src/Monomer/Graphics/NanoVGRenderer.hs

@@ -353,11 +353,15 @@ newRenderer c rdpr envRef = Renderer {..} where
     req = ImageReq name def Nothing ImageDelete []
 
 loadFont :: VG.Context -> Set Text -> FontDef -> IO (Set Text)
-loadFont c fonts (FontDef name path) = do
-  res <- VG.createFont c name (VG.FileName path)
+loadFont c fonts fontDef = do
+  res <- createFont fontDef
   case res of
     Just{} -> return $ Set.insert name fonts
     _ -> putStrLnErr ("Failed to load font: " ++ T.unpack name) >> return fonts
+  where
+    name = fontDef ^. L.fontName
+    createFont FontDefFile{} = VG.createFont c name (VG.FileName $ fontDef ^. L.fontPath)
+    createFont FontDefMem{} = VG.createFontMem c name (fontDef ^. L.fontBytes)
 
 setFont
   :: VG.Context

src/Monomer/Graphics/Types.hs

@@ -10,7 +10,10 @@ Basic types for Graphics.
 
 Angles are always expressed in degrees, not radians.
 -}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE Strict #-}
 
 module Monomer.Graphics.Types where
@@ -45,11 +48,16 @@ data Color = Color {
 instance Default Color where
   def = Color 255 255 255 1.0
 
--- | The definition of a font.
-data FontDef = FontDef {
-  _fntName :: !Text,  -- ^ The logic name. Will be used when defining styles.
-  _fntPath :: !Text   -- ^ The path in the filesystem.
-} deriving (Eq, Show, Generic)
+data FontDef
+  = FontDefFile
+    { _fntFontName :: !Text  -- ^ The logic name. Will be used when defining styles.
+    , _fntFontPath :: !Text  -- ^ The path in the filesystem.
+    }
+  | FontDefMem
+    { _fntFontName :: !Text         -- ^ The logic name. Will be used when defining styles.
+    , _fntFontBytes :: !ByteString  -- ^ The bytes of the loaded font.
+    }
+  deriving (Eq, Show, Generic)
 
 -- | The name of a loaded font.
 newtype Font

src/Monomer/Main/Types.hs

@@ -41,6 +41,7 @@ import Monomer.Core.ThemeTypes
 import Monomer.Core.WidgetTypes
 import Monomer.Event.Types
 import Monomer.Graphics.Types
+import Data.ByteString (ByteString)
 
 -- | Main Monomer monad.
 type MonomerM s e m = (Eq s, MonadState (MonomerCtx s e) m, MonadCatch m, MonadIO m)
@@ -385,9 +386,24 @@ appDisableAutoScale disable = def {
 Available fonts to the application. An empty list will make it impossible to
 render text.
 -}
-appFontDef :: Text -> Text -> AppConfig e
-appFontDef name path = def {
-  _apcFonts = [ FontDef name path ]
+appFontDefFile :: Text -> Text -> AppConfig e
+appFontDefFile name path = def {
+  _apcFonts = [ FontDefFile name path ]
+}
+
+{- |
+Alias for 'appFontDefFile' for backwards compatibility.
+-}
+appFontDef = appFontDefFile
+{-# DEPRECATED appFontDef "Use appFontDefFile directly" #-}
+
+{-|
+Available fonts to the application. An empty list will make it impossible to
+render text.
+-}
+appFontDefMem :: Text -> ByteString -> AppConfig e
+appFontDefMem name bytes = def {
+  _apcFonts = [ FontDefMem name bytes ]
 }
 
 -- | Initial theme.