{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

{-| Font glyph ranges builder

Helper to build glyph ranges from text/string data.
Feed your application strings/characters to it then call 'buildRanges'.

Low-level example of usage:

@
  -- import ImGui.Fonts
  -- import ImGui.Raw.GlyphRangesBuilder as GRB

  builder <- GRB.new

  GRB.addRanges builder getGlyphRangesDefault
  liftIO $ withCString "Привет" $ GRB.addText builder
  rangesVec <- GRB.buildRanges builder
  let ranges = GRB.fromRangesVector rangesVec

  addFontFromFileTTF'
    "./imgui/misc/fonts/DroidSans.ttf" 12
    Nothing
    (Just ranges)

  -- it is strictly necessary to explicitly build the atlas
  buildFontAtlas

  -- resource destruction comes only after the building
  GRB.destroyRangesVector rangesVec
  GRB.destroy builder
@

-}

module DearImGui.Raw.Font.GlyphRanges
  ( GlyphRanges(..)

    -- * Built-in ranges
  , Builtin(..)
  , getBuiltin
  , builtinSetup

    -- * Preparing a builder
  , GlyphRangesBuilder(..)
  , new
  , destroy
  , addChar
  , addText
  , addRanges

    -- * Extracting data
  , GlyphRangesVector(..)
  , buildRangesVector
  , fromRangesVector
  , destroyRangesVector
  )
  where

-- base
import Control.Monad.IO.Class
  ( MonadIO, liftIO )
import Foreign ( Ptr )
import Foreign.C
import System.IO.Unsafe (unsafePerformIO)

-- dear-imgui
import DearImGui.Raw.Context
  ( imguiContext )
import DearImGui.Structs

-- inline-c
import qualified Language.C.Inline as C

-- inline-c-cpp
import qualified Language.C.Inline.Cpp as Cpp

C.context (Cpp.cppCtx <> C.bsCtx <> imguiContext)
C.include "imgui.h"
Cpp.using "namespace ImGui"

-- | Glyph ranges handle
--
-- Wraps @ImWchar*@.
newtype GlyphRanges = GlyphRanges (Ptr ImWchar)

-- | Builtin glyph ranges tags.
data Builtin
  = Latin
  | Korean
  | Japanese
  | ChineseFull
  | ChineseSimplifiedCommon
  | Cyrillic
  | Thai
  | Vietnamese
  deriving (Builtin -> Builtin -> Bool
(Builtin -> Builtin -> Bool)
-> (Builtin -> Builtin -> Bool) -> Eq Builtin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Builtin -> Builtin -> Bool
== :: Builtin -> Builtin -> Bool
$c/= :: Builtin -> Builtin -> Bool
/= :: Builtin -> Builtin -> Bool
Eq, Eq Builtin
Eq Builtin =>
(Builtin -> Builtin -> Ordering)
-> (Builtin -> Builtin -> Bool)
-> (Builtin -> Builtin -> Bool)
-> (Builtin -> Builtin -> Bool)
-> (Builtin -> Builtin -> Bool)
-> (Builtin -> Builtin -> Builtin)
-> (Builtin -> Builtin -> Builtin)
-> Ord Builtin
Builtin -> Builtin -> Bool
Builtin -> Builtin -> Ordering
Builtin -> Builtin -> Builtin
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Builtin -> Builtin -> Ordering
compare :: Builtin -> Builtin -> Ordering
$c< :: Builtin -> Builtin -> Bool
< :: Builtin -> Builtin -> Bool
$c<= :: Builtin -> Builtin -> Bool
<= :: Builtin -> Builtin -> Bool
$c> :: Builtin -> Builtin -> Bool
> :: Builtin -> Builtin -> Bool
$c>= :: Builtin -> Builtin -> Bool
>= :: Builtin -> Builtin -> Bool
$cmax :: Builtin -> Builtin -> Builtin
max :: Builtin -> Builtin -> Builtin
$cmin :: Builtin -> Builtin -> Builtin
min :: Builtin -> Builtin -> Builtin
Ord, Int -> Builtin -> ShowS
[Builtin] -> ShowS
Builtin -> String
(Int -> Builtin -> ShowS)
-> (Builtin -> String) -> ([Builtin] -> ShowS) -> Show Builtin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Builtin -> ShowS
showsPrec :: Int -> Builtin -> ShowS
$cshow :: Builtin -> String
show :: Builtin -> String
$cshowList :: [Builtin] -> ShowS
showList :: [Builtin] -> ShowS
Show, Int -> Builtin
Builtin -> Int
Builtin -> [Builtin]
Builtin -> Builtin
Builtin -> Builtin -> [Builtin]
Builtin -> Builtin -> Builtin -> [Builtin]
(Builtin -> Builtin)
-> (Builtin -> Builtin)
-> (Int -> Builtin)
-> (Builtin -> Int)
-> (Builtin -> [Builtin])
-> (Builtin -> Builtin -> [Builtin])
-> (Builtin -> Builtin -> [Builtin])
-> (Builtin -> Builtin -> Builtin -> [Builtin])
-> Enum Builtin
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Builtin -> Builtin
succ :: Builtin -> Builtin
$cpred :: Builtin -> Builtin
pred :: Builtin -> Builtin
$ctoEnum :: Int -> Builtin
toEnum :: Int -> Builtin
$cfromEnum :: Builtin -> Int
fromEnum :: Builtin -> Int
$cenumFrom :: Builtin -> [Builtin]
enumFrom :: Builtin -> [Builtin]
$cenumFromThen :: Builtin -> Builtin -> [Builtin]
enumFromThen :: Builtin -> Builtin -> [Builtin]
$cenumFromTo :: Builtin -> Builtin -> [Builtin]
enumFromTo :: Builtin -> Builtin -> [Builtin]
$cenumFromThenTo :: Builtin -> Builtin -> Builtin -> [Builtin]
enumFromThenTo :: Builtin -> Builtin -> Builtin -> [Builtin]
Enum, Builtin
Builtin -> Builtin -> Bounded Builtin
forall a. a -> a -> Bounded a
$cminBound :: Builtin
minBound :: Builtin
$cmaxBound :: Builtin
maxBound :: Builtin
Bounded)

-- | Get builtin glyph ranges from a tag.
getBuiltin :: Builtin -> GlyphRanges
getBuiltin :: Builtin -> GlyphRanges
getBuiltin = \case
  Builtin
Latin                   -> GlyphRanges
getGlyphRangesDefault
  Builtin
Korean                  -> GlyphRanges
getGlyphRangesKorean
  Builtin
Japanese                -> GlyphRanges
getGlyphRangesJapanese
  Builtin
ChineseFull             -> GlyphRanges
getGlyphRangesChineseFull
  Builtin
ChineseSimplifiedCommon -> GlyphRanges
getGlyphRangesChineseSimplifiedCommon
  Builtin
Cyrillic                -> GlyphRanges
getGlyphRangesCyrillic
  Builtin
Thai                    -> GlyphRanges
getGlyphRangesThai
  Builtin
Vietnamese              -> GlyphRanges
getGlyphRangesVietnamese

-- | Special case of @getBuiltin@, but for font source setup.
builtinSetup :: Builtin -> Maybe GlyphRanges
builtinSetup :: Builtin -> Maybe GlyphRanges
builtinSetup = \case
  Builtin
Latin -> Maybe GlyphRanges
forall a. Maybe a
Nothing
  Builtin
others  -> GlyphRanges -> Maybe GlyphRanges
forall a. a -> Maybe a
Just (Builtin -> GlyphRanges
getBuiltin Builtin
others)

-- | Basic Latin, Extended Latin
getGlyphRangesDefault :: GlyphRanges
getGlyphRangesDefault :: GlyphRanges
getGlyphRangesDefault = IO GlyphRanges -> GlyphRanges
forall a. IO a -> a
unsafePerformIO do
  Ptr ImWchar -> GlyphRanges
GlyphRanges (Ptr ImWchar -> GlyphRanges) -> IO (Ptr ImWchar) -> IO GlyphRanges
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Ptr ImWchar)
[C.block|
    const ImWchar* {
      return GetIO().Fonts->GetGlyphRangesDefault();
    }
  |]

-- | Default + Korean characters
getGlyphRangesKorean :: GlyphRanges
getGlyphRangesKorean :: GlyphRanges
getGlyphRangesKorean = IO GlyphRanges -> GlyphRanges
forall a. IO a -> a
unsafePerformIO do
  Ptr ImWchar -> GlyphRanges
GlyphRanges (Ptr ImWchar -> GlyphRanges) -> IO (Ptr ImWchar) -> IO GlyphRanges
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Ptr ImWchar)
[C.block|
    const ImWchar* {
      return GetIO().Fonts->GetGlyphRangesKorean();
    }
  |]

-- | Default + Hiragana, Katakana, Half-Width, Selection of 2999 Ideographs
getGlyphRangesJapanese :: GlyphRanges
getGlyphRangesJapanese :: GlyphRanges
getGlyphRangesJapanese = IO GlyphRanges -> GlyphRanges
forall a. IO a -> a
unsafePerformIO do
  Ptr ImWchar -> GlyphRanges
GlyphRanges (Ptr ImWchar -> GlyphRanges) -> IO (Ptr ImWchar) -> IO GlyphRanges
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Ptr ImWchar)
[C.block|
    const ImWchar* {
      return GetIO().Fonts->GetGlyphRangesJapanese();
    }
  |]

-- | Default + Half-Width + Japanese Hiragana/Katakana + full set of about 21000 CJK Unified Ideographs
getGlyphRangesChineseFull :: GlyphRanges
getGlyphRangesChineseFull :: GlyphRanges
getGlyphRangesChineseFull = IO GlyphRanges -> GlyphRanges
forall a. IO a -> a
unsafePerformIO do
  Ptr ImWchar -> GlyphRanges
GlyphRanges (Ptr ImWchar -> GlyphRanges) -> IO (Ptr ImWchar) -> IO GlyphRanges
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Ptr ImWchar)
[C.block|
    const ImWchar* {
      return GetIO().Fonts->GetGlyphRangesChineseFull();
    }
  |]

-- | Default + Half-Width + Japanese Hiragana/Katakana + set of 2500 CJK Unified Ideographs for common simplified Chinese
getGlyphRangesChineseSimplifiedCommon :: GlyphRanges
getGlyphRangesChineseSimplifiedCommon :: GlyphRanges
getGlyphRangesChineseSimplifiedCommon = IO GlyphRanges -> GlyphRanges
forall a. IO a -> a
unsafePerformIO do
  Ptr ImWchar -> GlyphRanges
GlyphRanges (Ptr ImWchar -> GlyphRanges) -> IO (Ptr ImWchar) -> IO GlyphRanges
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Ptr ImWchar)
[C.block|
    const ImWchar* {
      return GetIO().Fonts->GetGlyphRangesChineseSimplifiedCommon();
    }
  |]

-- | Default + about 400 Cyrillic characters
getGlyphRangesCyrillic :: GlyphRanges
getGlyphRangesCyrillic :: GlyphRanges
getGlyphRangesCyrillic = IO GlyphRanges -> GlyphRanges
forall a. IO a -> a
unsafePerformIO do
  Ptr ImWchar -> GlyphRanges
GlyphRanges (Ptr ImWchar -> GlyphRanges) -> IO (Ptr ImWchar) -> IO GlyphRanges
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Ptr ImWchar)
[C.block|
    const ImWchar* {
      return GetIO().Fonts->GetGlyphRangesCyrillic();
    }
  |]

-- | Default + Thai characters
getGlyphRangesThai :: GlyphRanges
getGlyphRangesThai :: GlyphRanges
getGlyphRangesThai = IO GlyphRanges -> GlyphRanges
forall a. IO a -> a
unsafePerformIO do
  Ptr ImWchar -> GlyphRanges
GlyphRanges (Ptr ImWchar -> GlyphRanges) -> IO (Ptr ImWchar) -> IO GlyphRanges
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Ptr ImWchar)
[C.block|
    const ImWchar* {
      return GetIO().Fonts->GetGlyphRangesThai();
    }
  |]

-- | Default + Vietnamese characters
getGlyphRangesVietnamese :: GlyphRanges
getGlyphRangesVietnamese :: GlyphRanges
getGlyphRangesVietnamese = IO GlyphRanges -> GlyphRanges
forall a. IO a -> a
unsafePerformIO do
  Ptr ImWchar -> GlyphRanges
GlyphRanges (Ptr ImWchar -> GlyphRanges) -> IO (Ptr ImWchar) -> IO GlyphRanges
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Ptr ImWchar)
[C.block|
    const ImWchar* {
      return GetIO().Fonts->GetGlyphRangesVietnamese();
    }
  |]

-- | Glyph ranges builder handle
--
-- Wraps @ImFontGlyphRangesBuilder*@.
newtype GlyphRangesBuilder = GlyphRangesBuilder (Ptr ImFontGlyphRangesBuilder)

-- | Glyph ranges vector handle to keep builder output
--
-- Wraps @ImVector<ImWchar>*@.
newtype GlyphRangesVector = GlyphRangesVector (Ptr ())


-- | Create an instance of builder
new :: MonadIO m => m GlyphRangesBuilder
new :: forall (m :: * -> *). MonadIO m => m GlyphRangesBuilder
new = IO GlyphRangesBuilder -> m GlyphRangesBuilder
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
  Ptr ImFontGlyphRangesBuilder -> GlyphRangesBuilder
GlyphRangesBuilder (Ptr ImFontGlyphRangesBuilder -> GlyphRangesBuilder)
-> IO (Ptr ImFontGlyphRangesBuilder) -> IO GlyphRangesBuilder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Ptr ImFontGlyphRangesBuilder)
[C.block|
    ImFontGlyphRangesBuilder* {
      return IM_NEW(ImFontGlyphRangesBuilder);
    }
  |]

-- | Destroy an instance of builder
--
-- Should be used __after__ font atlas building.
destroy :: MonadIO m => GlyphRangesBuilder -> m ()
destroy :: forall (m :: * -> *). MonadIO m => GlyphRangesBuilder -> m ()
destroy (GlyphRangesBuilder Ptr ImFontGlyphRangesBuilder
builder) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
  [C.block|
    void {
      IM_DELETE($(ImFontGlyphRangesBuilder* builder));
    }
  |]


-- | Add character
addChar :: MonadIO m => GlyphRangesBuilder -> ImWchar -> m ()
addChar :: forall (m :: * -> *).
MonadIO m =>
GlyphRangesBuilder -> ImWchar -> m ()
addChar (GlyphRangesBuilder Ptr ImFontGlyphRangesBuilder
builder) ImWchar
wChar = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
  [C.block|
    void {
      $(ImFontGlyphRangesBuilder* builder)->AddChar($(ImWchar wChar));
    }
  |]

-- | Add string (each character of the UTF-8 string are added)
addText :: MonadIO m => GlyphRangesBuilder -> CString -> m ()
addText :: forall (m :: * -> *).
MonadIO m =>
GlyphRangesBuilder -> CString -> m ()
addText (GlyphRangesBuilder Ptr ImFontGlyphRangesBuilder
builder) CString
string = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
  [C.block|
    void {
      $(ImFontGlyphRangesBuilder* builder)->AddText($(char* string));
    }
  |]
-- FIXME: the function uses 'const char* text_end = NULL' parameter,
--   which is pointer for the line ending. It is low level, though it
--   could be utilized for string length parameter.

-- | Add ranges, e.g. 'addRanges builder getGlyphRangesDefault'
-- to force add all of ASCII/Latin+Ext
addRanges :: MonadIO m => GlyphRangesBuilder -> GlyphRanges -> m()
addRanges :: forall (m :: * -> *).
MonadIO m =>
GlyphRangesBuilder -> GlyphRanges -> m ()
addRanges (GlyphRangesBuilder Ptr ImFontGlyphRangesBuilder
builder) (GlyphRanges Ptr ImWchar
ranges) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
  [C.block|
    void {
      $(ImFontGlyphRangesBuilder* builder)->AddRanges($(ImWchar* ranges));
    }
  |]


-- | Build new ranges and create ranges vector instance,
-- containing them
buildRangesVector :: MonadIO m => GlyphRangesBuilder -> m (GlyphRangesVector)
buildRangesVector :: forall (m :: * -> *).
MonadIO m =>
GlyphRangesBuilder -> m GlyphRangesVector
buildRangesVector (GlyphRangesBuilder Ptr ImFontGlyphRangesBuilder
builder) = IO GlyphRangesVector -> m GlyphRangesVector
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
  Ptr () -> GlyphRangesVector
GlyphRangesVector (Ptr () -> GlyphRangesVector)
-> IO (Ptr ()) -> IO GlyphRangesVector
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.block|
    void* {
      ImVector<ImWchar>* ranges = IM_NEW(ImVector<ImWchar>);
      $(ImFontGlyphRangesBuilder* builder)->BuildRanges(ranges);
      return ranges;
    }
  |]

-- | Extract glyph ranges from a vector
--
-- Should be used __before__ vector destruction.
fromRangesVector :: GlyphRangesVector -> GlyphRanges
fromRangesVector :: GlyphRangesVector -> GlyphRanges
fromRangesVector (GlyphRangesVector Ptr ()
vecPtr) = IO GlyphRanges -> GlyphRanges
forall a. IO a -> a
unsafePerformIO do
  Ptr ImWchar -> GlyphRanges
GlyphRanges (Ptr ImWchar -> GlyphRanges) -> IO (Ptr ImWchar) -> IO GlyphRanges
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.block|
    ImWchar* {
      return ((ImVector<ImWchar>*) $(void* vecPtr))->Data;
    }
  |]

-- | Destroy a ranges vector instance
--
-- Should be used __after__ font atlas building.
destroyRangesVector :: MonadIO m => GlyphRangesVector -> m ()
destroyRangesVector :: forall (m :: * -> *). MonadIO m => GlyphRangesVector -> m ()
destroyRangesVector (GlyphRangesVector Ptr ()
vecPtr) = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
  [C.block|
    void {
      IM_DELETE(((ImVector<ImWchar>*) $(void* vecPtr)));
    }
  |]