diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +.stack-work/ +load-font.cabal +*~ diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for font-load + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2018 + +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 Author name here 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. diff --git a/README.org b/README.org new file mode 100644 --- /dev/null +++ b/README.org @@ -0,0 +1,16 @@ +* Load Font + This library aims to a cross-platform (Win/Lin/OSX) way to load a custom font bundled with your Haskell app. The font is automatically unloaded when the app exits. + + It ships with the [[https://www.dafont.com/moon-phases.font][Moon Phases]] font and a GUI demo, ~load-font-exe~ that uses the [[https://hackage.haskell.org/package/fltkhs][FLTKHS]] Haskell GUI library to show that Moon Phases is indeed loaded. It has been tested on Arch Linux, Windows 10 and OSX Sierra. + + While the demo uses FLTKHS font loading and unloading it is agnostic to the GUI framework. FLTKHS is used here simply because it's the easiest to build and install. + + This library owes its existence to [[https://groups.google.com/d/msg/fltkgeneral/uAdg8wOLiMk/_CzBu995AwAJ][Albrecht Schlosser's post on the FLTK mailing list]]. + + To run the demo, clone this repo and do: + #+BEGIN_EXAMPLE + > stack build --flag fltkhs:bundled + > stack exec load-font-exe + #+END_EXAMPLE + + [[file:screenshot-demo.jpg]] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where +import Graphics.UI.Font.Load +import Paths_load_font +import Graphics.UI.FLTK.LowLevel.Fl_Enumerations +import qualified Graphics.UI.FLTK.LowLevel.FL as FL +import Graphics.UI.FLTK.LowLevel.Fl_Types +import Graphics.UI.FLTK.LowLevel.FLTKHS + +drawFonts :: Font -> Ref Box -> IO () +drawFonts moonPhasesFont b = do + label <- getLabel b + bounds@(Rectangle (Position (X x') (Y y')) _) <- getRectangle b + flcPushClip bounds + flcSetColor blackColor + flcSetFont helvetica (FontSize 18) + flcDraw "It says \"Hello World!\" in Moon Phases:" (Position (X (x'+25)) (Y (y'+40))) + flcSetFont moonPhasesFont (FontSize 30) + flcDraw "Hello world!" (Position (X (x'+25)) (Y (y'+90))) + flcPopClip + +main :: IO () +main = do + fontPath <- getDataFileName "test-fonts/moon_phases.ttf" + loadFont fontPath + numFaces <- FL.setFonts Nothing + let fonts = map Font [0 .. numFaces - 1] + withFaces <- mapM + (\f -> do + (face,_) <- FL.getFontName f + return (face,f) + ) + fonts + case (lookup "Moon Phases" withFaces) of + Nothing -> flMessage "The Moon Phases test font was not loaded!" + Just f -> do + win <- windowNew + (Size (Width 400) (Height 120)) + Nothing + (Just "Font Load Demo") + setColor win whiteColor + begin win + b <- boxCustom + (toRectangle (0,0,400,120)) + Nothing + (Just (drawFonts f)) + Nothing + setBox b FlatBox + end win + showWidget win + _ <- FL.run + return () diff --git a/load-font.cabal b/load-font.cabal new file mode 100644 --- /dev/null +++ b/load-font.cabal @@ -0,0 +1,67 @@ +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: f0d79e490fdec5930d56c78d859e5922183c991f5459dbbf6b10f130560ffb12 + +name: load-font +version: 0.1.0.0 +synopsis: A cross platform library for loading bundled fonts into your application +description: Please see the README on Github at +category: UI,Graphics,GUI,User Interfaces, Font +homepage: https://github.com/deech/load-font#readme +bug-reports: https://github.com/deech/load-font/issues +author: Aditya Siram +maintainer: aditya.siram@gmail.com +copyright: 2018 Aditya Siram +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + ChangeLog.md + src/cbits/font_load.c + +data-files: + test-fonts/moon_phases.ttf + +source-repository head + type: git + location: https://github.com/deech/load-font + +library + hs-source-dirs: + src + include-dirs: + src/cbits + c-sources: + src/cbits/font_load.c + build-depends: + base >=4.7 && <5 + build-tools: + c2hs + exposed-modules: + Graphics.UI.Font.Load + other-modules: + Graphics.UI.Font.LoadCWrapper + Paths_load_font + default-language: Haskell2010 + +executable load-font-exe + main-is: Main.hs + hs-source-dirs: + app + ghc-options: -O2 + build-depends: + base >=4.7 && <5 + , fltkhs >=0.5.4.4 + , load-font + , text >=1.2.2.0 + if (os(linux) || os(windows)) + ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition" "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + else + ghc-options: -optl-Wl,-lfltkc + other-modules: + Paths_load_font + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,48 @@ +name: load-font +version: 0.1.0.0 +github: "deech/load-font" +license: BSD3 +author: "Aditya Siram" +maintainer: "aditya.siram@gmail.com" +copyright: "2018 Aditya Siram" +synopsis: A cross platform library for loading bundled fonts into your application +category: UI,Graphics,GUI,User Interfaces, Font +extra-source-files: +- src/cbits/font_load.c +- README.md +- ChangeLog.md +data-files: +- test-fonts/*.ttf + +description: Please see the README on Github at + +dependencies: +- base >= 4.7 && < 5 + +library: + source-dirs: src + exposed-modules: Graphics.UI.Font.Load + build-tools: c2hs + c-sources: + - src/cbits/font_load.c + include-dirs: src/cbits + +executables: + load-font-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - load-font + - fltkhs >= 0.5.4.4 + - text >= 1.2.2.0 + ghc-options: -O2 + when: + - condition: (os(linux) || os(windows)) + then: + ghc-options: -pgml g++ "-optl-Wl,--allow-multiple-definition" "-optl-Wl,--whole-archive" "-optl-Wl,-Bstatic" "-optl-Wl,-lfltkc" "-optl-Wl,-Bdynamic" "-optl-Wl,--no-whole-archive" + else: + ghc-options: "-optl-Wl,-lfltkc" diff --git a/screenshot-demo.jpg b/screenshot-demo.jpg new file mode 100644 Binary files /dev/null and b/screenshot-demo.jpg differ diff --git a/src/Graphics/UI/Font/Load.hs b/src/Graphics/UI/Font/Load.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Font/Load.hs @@ -0,0 +1,50 @@ +module Graphics.UI.Font.Load + ( + loadFont + , unloadFont + ) +where +import Foreign.C.String +import Control.Applicative +import Foreign.C.Types +import qualified Graphics.UI.Font.LoadCWrapper as CWrapper +-- | +-- Remove a private font located at 'FilePath' from the application. +-- +-- For the most part you shouldn't need this function because private fonts are +-- automatically unloaded when the process exits but it's available in case +-- you're doing something more exotic like switching between two versions of the +-- same font. +-- +-- On Windows and OSX this works as you would expect. But on Linux the only +-- available function is +-- +-- which ignores the 'FilePath' and removes /all/ private +-- fonts. This adheres violently to the Principle Of Greatest Surprise and in +-- the future I will transparently reload the other fonts but for now, caveat +-- computer. +unloadFont :: FilePath -> IO () +unloadFont fp = withCString fp (\pathPtr -> CWrapper.unloadFont pathPtr) + +-- | +-- Make a font located at some 'FilePath' available to your application. The font is automatically cleared from the font database with the process exits. +-- +-- On Linux this uses +-- +-- under the hood and so assumes X11/Xft are available. +-- It should work fine on modern Linux systems but will break with old Xlib +-- legacy fonts. +-- +-- Currently the error case just returns a pretty uninformative message +-- because underlying calls on Linux and Windows which are out of my control +-- only return 0 or 1 in case of failure or success. Given this it would make more sense that +-- the return type should be 'Maybe ()' but 'Either String ()' has two advantages +-- 1. It makes errors easier to collect when batch loading +-- 2. OSX has a which I plan to expose in the future +loadFont :: FilePath -> IO (Either String ()) +loadFont fp = withCString fp (\pathPtr -> do + res <- CWrapper.loadFont pathPtr + case res of + Left _ -> return (Left ("Unable to load: " ++ fp)) + Right () -> return (Right ()) + ) diff --git a/src/Graphics/UI/Font/LoadCWrapper.chs b/src/Graphics/UI/Font/LoadCWrapper.chs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Font/LoadCWrapper.chs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} +module Graphics.UI.Font.LoadCWrapper + ( + loadFont + , unloadFont + ) +where +import Foreign.C.String +import Control.Applicative +import Foreign.C.Types +#include "font_load.h" +{# fun load_private_font as loadFont' { `CString' } -> `CInt' #} +loadFont :: CString -> IO (Either String ()) +loadFont pathPtr = do + res <- loadFont' pathPtr + case res of + 0 -> return (Left "") + _ -> return (Right ()) +{# fun unload_private_font as unloadFont { `CString' } -> `()' #} diff --git a/src/cbits/font_load.c b/src/cbits/font_load.c new file mode 100644 --- /dev/null +++ b/src/cbits/font_load.c @@ -0,0 +1,56 @@ +#include "font_load.h" +#ifdef _WIN32 +#define _WIN32_WINNT 0x0501 /* need at least WinXP for this API, I think */ +#include +#elif defined(__APPLE__) +#include +#else /* Assume X11 with XFT/fontconfig - this will break on systems using legacy Xlib fonts */ +#include +#define USE_XFT 1 +#endif + +// Create some portability wrappers +#ifdef _WIN32 +int load_private_font(_In_ LPCTSTR path) { + return AddFontResourceEx(path, FR_PRIVATE, 0); +} +void unload_private_font(_In_ LPCTSTR path) { + RemoveFontResourceEx(path, FR_PRIVATE, 0); +} + +#elif defined(__APPLE__) +int load_private_font(const char *pf) { + int result = 0; + CFErrorRef errRef; + // Make a URL from the font name given + CFURLRef fontURL = CFURLCreateFromFileSystemRepresentation(kCFAllocatorDefault, (const UInt8 *)pf, strlen(pf), false); + // Try to load the font file + if (CTFontManagerRegisterFontsForURL(fontURL, kCTFontManagerScopeProcess, &errRef)) { + result = 1; + } else { + result = 0; + } + // discard the fontURL + if (fontURL) + CFRelease(fontURL); + return result; +} // load_private_font + +void unload_private_font(const char *pf) { + CFErrorRef err; + // Make a URL from the font name given + CFURLRef fontURL = CFURLCreateFromFileSystemRepresentation(kCFAllocatorDefault, (const UInt8 *)pf, strlen(pf), false); + // Try to unregister the font + CTFontManagerUnregisterFontsForURL(fontURL, kCTFontManagerScopeProcess, &err); + if (fontURL) + CFRelease(fontURL); +} // unload_private_font + +#else /* Assume X11 with XFT/fontconfig - will break on systems using legacy Xlib fonts */ +int load_private_font(const char* path) { + return (int)FcConfigAppFontAddFile(0, (const FcChar8 *)(path)); +} +void unload_private_font(const char* path) { + FcConfigAppFontClear(0); +} +#endif diff --git a/src/cbits/font_load.h b/src/cbits/font_load.h new file mode 100644 --- /dev/null +++ b/src/cbits/font_load.h @@ -0,0 +1,2 @@ +int load_private_font(const char* path); +void unload_private_font(const char* path); diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,7 @@ +resolver: lts-10.7 +packages: +- . +allow-newer: true +extra-deps: +- c2hs-0.28.3 +- fltkhs-0.5.4.4 diff --git a/test-fonts/moon_phases.ttf b/test-fonts/moon_phases.ttf new file mode 100644 Binary files /dev/null and b/test-fonts/moon_phases.ttf differ