mirror of
https://github.com/Drezil/dear-imgui.hs.git
synced 2025-04-21 10:54:00 +00:00
504 lines
14 KiB
Haskell
504 lines
14 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
{-|
|
|
Module: DearImGui.FontAtlas
|
|
|
|
Font atlas builder, accompanied with lower-level functions.
|
|
|
|
@
|
|
import qualified DearImGui.FontAtlas as FontAtlas
|
|
|
|
prepareAtlas =
|
|
FontAtlas.rebuild
|
|
[ FontAtlas.FileTTF "comic-sans-mono.ttf" 13 csOptions csRanges
|
|
, FontAtlas.Default
|
|
]
|
|
where
|
|
csOptions = mconcat
|
|
[ FontAtlas.fontNo 1
|
|
, FontAtlas.glyphOffset (0, -1)
|
|
]
|
|
|
|
csRanges = RangeBuilder $ mconcat
|
|
[ FontAtlas.addText "Hello world"
|
|
, FontRanges.addChar 'Ꙑ'
|
|
, FontRanges.addRanges FontRanges.Korean
|
|
]
|
|
@
|
|
|
|
-}
|
|
|
|
module DearImGui.FontAtlas
|
|
( -- * Main types
|
|
Raw.Font(..)
|
|
, FontSource(..)
|
|
-- * Building atlas
|
|
, rebuild
|
|
-- ** Configuring sources
|
|
, ConfigSetup(..)
|
|
, fontDataOwnedByAtlas
|
|
, fontNo
|
|
, sizePixels
|
|
, oversampleH
|
|
, oversampleV
|
|
, pixelSnapH
|
|
, glyphExtraSpacing
|
|
, glyphOffset
|
|
, glyphRanges
|
|
, glyphMinAdvanceX
|
|
, glyphMaxAdvanceX
|
|
, mergeMode
|
|
, fontBuilderFlags
|
|
, rasterizerMultiply
|
|
, ellipsisChar
|
|
|
|
-- ** Configuring ranges
|
|
, Ranges(..)
|
|
, RangesBuilderSetup(..)
|
|
, addChar
|
|
, addText
|
|
, addRanges
|
|
, addRangesRaw
|
|
|
|
, pattern Latin
|
|
, pattern Korean
|
|
, pattern Japanese
|
|
, pattern ChineseFull
|
|
, pattern ChineseSimplifiedCommon
|
|
, pattern Cyrillic
|
|
, pattern Thai
|
|
, pattern Vietnamese
|
|
|
|
-- * Lower level types and functions
|
|
-- , Raw.FontConfig(..)
|
|
-- , Raw.GlyphRanges(..)
|
|
, build
|
|
, clear
|
|
, setupFont
|
|
, setupRanges
|
|
, withRanges
|
|
, withConfig
|
|
, addFontFromFileTTF
|
|
, addFontFromFileTTF_
|
|
)
|
|
where
|
|
|
|
-- base
|
|
import Data.Bool (bool)
|
|
import Data.Maybe (fromMaybe)
|
|
import Foreign
|
|
import Foreign.C
|
|
|
|
-- transformers
|
|
import Control.Monad.IO.Class
|
|
( MonadIO, liftIO )
|
|
|
|
-- managed
|
|
import Control.Monad.Managed
|
|
( MonadManaged, managed )
|
|
import qualified Control.Monad.Managed as Managed
|
|
|
|
-- unlift
|
|
import UnliftIO (MonadUnliftIO)
|
|
import UnliftIO.Exception (bracket)
|
|
|
|
-- dear-imgui
|
|
import DearImGui.Raw.Font (Font(..))
|
|
import qualified DearImGui.Raw.Font as Raw
|
|
import DearImGui.Raw.Font.Config (FontConfig(..))
|
|
import qualified DearImGui.Raw.Font.Config as FontConfig
|
|
import DearImGui.Raw.Font.GlyphRanges (GlyphRanges(..), GlyphRangesBuilder(..))
|
|
import qualified DearImGui.Raw.Font.GlyphRanges as GlyphRanges
|
|
import DearImGui.Internal.Text (Text)
|
|
import qualified DearImGui.Internal.Text as Text
|
|
|
|
import DearImGui.Structs (ImVec2(..), ImWchar)
|
|
|
|
-- | Font setup data
|
|
data FontSource
|
|
= DefaultFont
|
|
| FromTTF FilePath Float (Maybe ConfigSetup) Ranges
|
|
-- TODO: FromMemory
|
|
|
|
-- | Font config monoid interface to be used in 'FontSource'.
|
|
--
|
|
-- @
|
|
-- mergeMode True <> fontNo 1
|
|
-- @
|
|
newtype ConfigSetup = ConfigSetup
|
|
{ applyToConfig :: FontConfig -> IO ()
|
|
}
|
|
|
|
instance Semigroup ConfigSetup where
|
|
ConfigSetup f <> ConfigSetup g =
|
|
ConfigSetup \fc -> f fc >> g fc
|
|
instance Monoid ConfigSetup where
|
|
mempty = ConfigSetup (const mempty)
|
|
|
|
-- | Glyph ranges settings, from presets to builder configuration.
|
|
data Ranges
|
|
= RangesRaw GlyphRanges
|
|
| RangesBuiltin GlyphRanges.Builtin
|
|
| RangesBuilder RangesBuilderSetup
|
|
|
|
-- | Basic Latin, Extended Latin
|
|
pattern Latin :: Ranges
|
|
pattern Latin = RangesBuiltin GlyphRanges.Latin
|
|
|
|
-- | Default + Korean characters
|
|
pattern Korean :: Ranges
|
|
pattern Korean = RangesBuiltin GlyphRanges.Korean
|
|
|
|
-- | Default + Hiragana, Katakana, Half-Width, Selection of 2999 Ideographs
|
|
pattern Japanese :: Ranges
|
|
pattern Japanese = RangesBuiltin GlyphRanges.Japanese
|
|
|
|
-- | Default + Half-Width + Japanese Hiragana/Katakana + full set of about 21000 CJK Unified Ideographs
|
|
pattern ChineseFull :: Ranges
|
|
pattern ChineseFull = RangesBuiltin GlyphRanges.ChineseFull
|
|
|
|
-- | Default + Half-Width + Japanese Hiragana/Katakana + set of 2500 CJK Unified Ideographs for common simplified Chinese
|
|
pattern ChineseSimplifiedCommon :: Ranges
|
|
pattern ChineseSimplifiedCommon = RangesBuiltin GlyphRanges.ChineseSimplifiedCommon
|
|
|
|
-- | Default + about 400 Cyrillic characters
|
|
pattern Cyrillic :: Ranges
|
|
pattern Cyrillic = RangesBuiltin GlyphRanges.Cyrillic
|
|
|
|
-- | Default + Thai characters
|
|
pattern Thai :: Ranges
|
|
pattern Thai = RangesBuiltin GlyphRanges.Thai
|
|
|
|
-- | Default + Vietnamese characters
|
|
pattern Vietnamese :: Ranges
|
|
pattern Vietnamese = RangesBuiltin GlyphRanges.Vietnamese
|
|
|
|
|
|
-- | Ranges builder monoid interface to be executed through 'buildRanges'.
|
|
--
|
|
-- @
|
|
-- addRanges FontRanges.DefaultRanges <> addText "Привет"
|
|
-- @
|
|
newtype RangesBuilderSetup = RangesBuilderSetup
|
|
{ applyToBuilder :: GlyphRangesBuilder -> IO ()
|
|
}
|
|
|
|
instance Semigroup RangesBuilderSetup where
|
|
RangesBuilderSetup f <> RangesBuilderSetup g =
|
|
RangesBuilderSetup \fc -> f fc >> g fc
|
|
|
|
instance Monoid RangesBuilderSetup where
|
|
mempty = RangesBuilderSetup (const mempty)
|
|
|
|
-- | Rebuild font atlas with provided configuration
|
|
-- and return corresponding structure of font handles
|
|
-- to be used with 'withFont'.
|
|
--
|
|
-- Accepts any 'Traversable' instance, so you are free to use
|
|
-- lists, maps or custom structures.
|
|
rebuild :: (MonadIO m, Traversable t) => t FontSource -> m (t Font)
|
|
rebuild sources = liftIO $ Managed.with action pure
|
|
where
|
|
action = do
|
|
clear
|
|
fonts <- traverse setupFont sources
|
|
build
|
|
return fonts
|
|
|
|
-- | Reset font atlas, clearing internal data
|
|
--
|
|
-- Alias for 'Raw.clearFontAtlas'
|
|
clear :: (MonadIO m) => m ()
|
|
clear = Raw.clearFontAtlas
|
|
|
|
-- | Build font atlas
|
|
--
|
|
-- Alias for 'Raw.buildFontAtlas'
|
|
build :: (MonadIO m) => m ()
|
|
build = Raw.buildFontAtlas
|
|
|
|
-- | Load a font from TTF file.
|
|
--
|
|
-- Specify font path and atlas glyph size.
|
|
--
|
|
-- Use 'Raw.addFontDefault' if you want to retain built-in font too.
|
|
--
|
|
-- Call 'build' after adding all the fonts,
|
|
-- particularly if you're loading them from memory or use custom glyphs.
|
|
-- Or stick to `rebuild` function.
|
|
--
|
|
-- Call backend-specific `CreateFontsTexture` before using 'newFrame'.
|
|
addFontFromFileTTF :: MonadIO m
|
|
=> FilePath -- ^ Font file path
|
|
-> Float -- ^ Font size in pixels
|
|
-> Maybe FontConfig -- ^ Configuration data
|
|
-> Maybe GlyphRanges -- ^ Glyph ranges to use
|
|
-> m (Maybe Font) -- ^ Returns font handle, if added successfully
|
|
addFontFromFileTTF font size config ranges = liftIO do
|
|
res@(Font ptr) <- withCString font \fontPtr ->
|
|
Raw.addFontFromFileTTF
|
|
fontPtr
|
|
(CFloat size)
|
|
(fromMaybe (FontConfig nullPtr) config)
|
|
(fromMaybe (GlyphRanges nullPtr) ranges)
|
|
pure $
|
|
if castPtr ptr == nullPtr
|
|
then Nothing
|
|
else Just res
|
|
-- FIXME: turn off asserts, so it would work
|
|
|
|
addFontFromFileTTF_ :: MonadIO m
|
|
=> FilePath -- ^ Font file path
|
|
-> Float -- ^ Font size in pixels
|
|
-> m (Maybe Raw.Font) -- ^ Returns font handle, if added successfully
|
|
addFontFromFileTTF_ font size =
|
|
addFontFromFileTTF font size Nothing Nothing
|
|
|
|
-- | Load a font with provided configuration, return its handle
|
|
-- and defer range builder and config destructors, if needed.
|
|
setupFont :: (MonadManaged m) => FontSource -> m Font
|
|
setupFont = \case
|
|
DefaultFont ->
|
|
Raw.addFontDefault
|
|
FromTTF path size configSetup ranges -> do
|
|
glyphRanges' <- setupRanges ranges
|
|
config <- managed (withConfig configSetup)
|
|
mFont <- addFontFromFileTTF path size config glyphRanges'
|
|
case mFont of
|
|
Nothing ->
|
|
liftIO . fail $ "Couldn't load font from " <> path
|
|
Just font ->
|
|
pure font
|
|
|
|
-- | Configure glyph ranges with provided configuration, return a handle
|
|
-- and defer builder destructors, if needed.
|
|
setupRanges :: (MonadManaged m) => Ranges -> m (Maybe GlyphRanges)
|
|
setupRanges = \case
|
|
RangesRaw ranges ->
|
|
pure $ Just ranges
|
|
RangesBuiltin builtin ->
|
|
pure $ GlyphRanges.builtinSetup builtin
|
|
RangesBuilder settings -> do
|
|
built <- managed $ withRanges settings
|
|
pure $ Just built
|
|
|
|
-- | Perform glyph ranges build based on provided configuration,
|
|
-- and execute a computation with built glyph ranges.
|
|
withRanges :: (MonadUnliftIO m) => RangesBuilderSetup -> (GlyphRanges -> m a) -> m a
|
|
withRanges (RangesBuilderSetup setup) fn =
|
|
bracket acquire release execute
|
|
where
|
|
acquire = do
|
|
builder <- GlyphRanges.new
|
|
liftIO $ setup builder
|
|
rangesVec <- GlyphRanges.buildRangesVector builder
|
|
return (rangesVec, builder)
|
|
|
|
release (rangesVec, builder) = do
|
|
GlyphRanges.destroyRangesVector rangesVec
|
|
GlyphRanges.destroy builder
|
|
|
|
execute (rangesVec, _) =
|
|
fn (GlyphRanges.fromRangesVector rangesVec)
|
|
|
|
-- | Configure font config with provided setup,
|
|
-- and execute a computation with built object.
|
|
-- return its handle and list of resource destructors.
|
|
withConfig :: (MonadUnliftIO m) => Maybe ConfigSetup -> (Maybe FontConfig -> m a) -> m a
|
|
withConfig mSetup action =
|
|
case mSetup of
|
|
Nothing ->
|
|
action Nothing
|
|
Just (ConfigSetup setup) ->
|
|
bracket acquire (FontConfig.destroy) (action . Just)
|
|
where
|
|
acquire = do
|
|
config <- FontConfig.new
|
|
liftIO $ setup config
|
|
return config
|
|
|
|
-- | Single Unicode character
|
|
addChar :: ImWchar -> RangesBuilderSetup
|
|
addChar char =
|
|
RangesBuilderSetup \builder ->
|
|
GlyphRanges.addChar builder char
|
|
|
|
-- | UTF-8 string
|
|
addText :: Text -> RangesBuilderSetup
|
|
addText str =
|
|
RangesBuilderSetup \builder ->
|
|
Text.withCString str (GlyphRanges.addText builder)
|
|
|
|
-- | Existing ranges (as is)
|
|
addRangesRaw :: GlyphRanges -> RangesBuilderSetup
|
|
addRangesRaw ranges =
|
|
RangesBuilderSetup \builder ->
|
|
GlyphRanges.addRanges builder ranges
|
|
|
|
-- | Existing ranges (through settings interface)
|
|
addRanges :: Ranges -> RangesBuilderSetup
|
|
addRanges = \case
|
|
RangesRaw ranges ->
|
|
addRangesRaw ranges
|
|
RangesBuilder settings ->
|
|
settings
|
|
RangesBuiltin builtin ->
|
|
addRangesRaw (GlyphRanges.getBuiltin builtin)
|
|
|
|
-- | TTF/OTF data ownership taken by the container ImFontAtlas (will delete memory itself).
|
|
--
|
|
-- By default, it is @true@
|
|
fontDataOwnedByAtlas :: Bool -> ConfigSetup
|
|
fontDataOwnedByAtlas value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setFontDataOwnedByAtlas fc (bool 0 1 value)
|
|
|
|
-- | Index of font within TTF/OTF file.
|
|
--
|
|
-- By default, it is @0@
|
|
fontNo :: Int -> ConfigSetup
|
|
fontNo value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setFontNo fc (fromIntegral value)
|
|
|
|
-- | Size in pixels for rasterizer
|
|
--
|
|
-- More or less maps to the resulting font height.
|
|
--
|
|
-- Implicitly set by @addFont...@ functions.
|
|
sizePixels :: Float -> ConfigSetup
|
|
sizePixels value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setSizePixels fc (CFloat value)
|
|
|
|
-- | Rasterize at higher quality for sub-pixel positioning.
|
|
--
|
|
-- Note: the difference between 2 and 3 is minimal so you can reduce this to 2 to save memory.
|
|
-- Read https://github.com/nothings/stb/blob/master/tests/oversample/README.md for details.
|
|
--
|
|
-- By default, it is @3@
|
|
oversampleH :: Int -> ConfigSetup
|
|
oversampleH value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setOversampleH fc (fromIntegral value)
|
|
|
|
-- | Rasterize at higher quality for sub-pixel positioning.
|
|
--
|
|
-- This is not really useful as we don't use sub-pixel positions on the Y axis.
|
|
--
|
|
-- By default, it is @1@
|
|
oversampleV :: Int -> ConfigSetup
|
|
oversampleV value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setOversampleV fc (fromIntegral value)
|
|
|
|
-- | Align every glyph to pixel boundary.
|
|
--
|
|
-- Useful if you are merging a non-pixel aligned font with the default font.
|
|
-- If enabled, you can set OversampleH/V to 1.
|
|
--
|
|
-- By default, it is @false@
|
|
pixelSnapH :: Bool -> ConfigSetup
|
|
pixelSnapH value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setPixelSnapH fc (bool 0 1 value)
|
|
|
|
-- | Extra spacing (in pixels) between glyphs.
|
|
--
|
|
-- Only X axis is supported for now.
|
|
--
|
|
-- By default, it is @0, 0@
|
|
glyphExtraSpacing :: (Float, Float) -> ConfigSetup
|
|
glyphExtraSpacing (x, y) =
|
|
ConfigSetup \fc ->
|
|
Foreign.with (ImVec2 x y) (FontConfig.setGlyphExtraSpacing fc)
|
|
|
|
-- | Offset all glyphs from this font input.
|
|
--
|
|
-- By default, it is @0, 0@
|
|
glyphOffset :: (Float, Float) -> ConfigSetup
|
|
glyphOffset (x, y) =
|
|
ConfigSetup \fc ->
|
|
Foreign.with (ImVec2 x y) (FontConfig.setGlyphOffset fc)
|
|
|
|
-- | Pointer to a user-provided list of Unicode range.
|
|
--
|
|
-- 2 values per range, inclusive. Zero-terminated list.
|
|
--
|
|
-- THE ARRAY DATA NEEDS TO PERSIST AS LONG AS THE FONT IS ALIVE.
|
|
--
|
|
-- By default, it is @NULL@
|
|
glyphRanges :: GlyphRanges -> ConfigSetup
|
|
glyphRanges value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setGlyphRanges fc value
|
|
|
|
-- | Minimum AdvanceX for glyphs.
|
|
--
|
|
-- Set Min to align font icons, set both Min/Max to enforce mono-space font.
|
|
--
|
|
-- By default, it is @0@
|
|
glyphMinAdvanceX :: Float -> ConfigSetup
|
|
glyphMinAdvanceX value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setGlyphMinAdvanceX fc (CFloat value)
|
|
|
|
-- | Maximum AdvanceX for glyphs.
|
|
--
|
|
-- By default, it is @FLT_MAX@.
|
|
glyphMaxAdvanceX :: Float -> ConfigSetup
|
|
glyphMaxAdvanceX value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setGlyphMaxAdvanceX fc (CFloat value)
|
|
|
|
-- | Merge into previous ImFont, so you can combine multiple inputs font into one ImFont.
|
|
--
|
|
-- e.g. ASCII font + icons + Japanese glyphs.
|
|
-- You may want to use @GlyphOffset.y@ when merging font of different heights.
|
|
--
|
|
-- By default, it is @false@
|
|
mergeMode :: Bool -> ConfigSetup
|
|
mergeMode value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setMergeMode fc (bool 0 1 value)
|
|
|
|
-- | Settings for custom font GlyphRanges.
|
|
--
|
|
-- THIS IS BUILDER IMPLEMENTATION DEPENDENT.
|
|
--
|
|
-- By default, it is @0@. Leave it so if unsure.
|
|
fontBuilderFlags :: Int -> ConfigSetup
|
|
fontBuilderFlags value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setFontBuilderFlags fc (fromIntegral value)
|
|
|
|
-- | Brighten (>1.0f) or darken (<1.0f) font output.
|
|
--
|
|
-- Brightening small fonts may be a good workaround to make them more readable.
|
|
--
|
|
-- By default, it is @1.0f@.
|
|
rasterizerMultiply :: Float -> ConfigSetup
|
|
rasterizerMultiply value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setRasterizerMultiply fc (CFloat value)
|
|
|
|
-- | Explicitly specify unicode codepoint of ellipsis character.
|
|
--
|
|
-- When fonts are being merged first specified ellipsis will be used.
|
|
--
|
|
-- By default, it is @-1@
|
|
ellipsisChar :: ImWchar -> ConfigSetup
|
|
ellipsisChar value =
|
|
ConfigSetup \fc ->
|
|
FontConfig.setEllipsisChar fc value
|