{-# LANGUAGE MagicHash, UnliftedFFITypes, DeriveGeneric #-}
module Data.Text.Glyphize.Buffer where

import qualified Data.Text.Internal.Lazy as Lazy
import qualified Data.Text.Lazy as Lazy (Text, pack)
import qualified Data.Text.Internal as Txt
import Data.Char (toUpper, toLower)
import Control.Monad (forM)
import Control.Exception (bracket)

import Data.Text.Glyphize.Oom (throwFalse, throwNull)

import qualified Data.Text.Array as A
import GHC.Exts (ByteArray#, sizeofByteArray#, Int#)
import Data.Word (Word32)
import Data.Int (Int32)
import Data.Bits ((.|.), (.&.), shiftR, shiftL, testBit)

import System.IO.Unsafe (unsafePerformIO)
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Ptr
import Foreign.C.String (CString, withCString, peekCString)
import Foreign.Storable (Storable(..))
import GHC.Generics (Generic(..))
import Foreign.Storable.Generic (GStorable(..))

------
--- Public Datastructures
------

-- | Text to be shaped or the resulting glyphs, for which language/script/direction/etc.
data Buffer = Buffer {
    Buffer -> Text
text :: Lazy.Text,
    -- ^ The Unicode text, in visual order, for HarfBuzz to convert into glyphs.
    -- See https://hackage.haskell.org/package/text-2.0.1/docs/Data-Text-Internal-Lazy.html#t:Text for details.
    Buffer -> Maybe ContentType
contentType :: Maybe ContentType,
    -- ^ What the bytes of the ByteString contents represents,
    -- namely unicode characters (before shaping) or glyphs (result of shaping).
    -- Typically callers should leave this as `Just ContentTypeUnicode`.
    Buffer -> Maybe Direction
direction :: Maybe Direction,
    -- ^ The text flow direction of the buffer.
    -- No shaping can happen without setting buffer direction, and it controls
    -- the visual direction for the output glyphs; for RTL direction the glyphs
    -- will be reversed. Many layout features depend on the proper setting of
    -- the direction, for example, reversing RTL text before shaping,
    -- then shaping with LTR direction is not the same as keeping the text in
    -- logical order and shaping with RTL direction.
    Buffer -> Maybe String
script :: Maybe String,
    -- ^ Script is crucial for choosing the proper shaping behaviour for scripts
    -- that require it (e.g. Arabic) and the which OpenType features defined in
    -- the font to be applied.
    Buffer -> Maybe String
language :: Maybe String,
    -- ^ Languages are crucial for selecting which OpenType feature to apply to
    -- the buffer which can result in applying language-specific behaviour.
    -- Languages are orthogonal to the scripts, and though they are related,
    -- they are different concepts and should not be confused with each other.
    Buffer -> Bool
beginsText :: Bool,
    -- ^ special handling of the beginning of text paragraph can be applied to
    -- this buffer. Should usually be set, unless you are passing to the buffer
    -- only part of the text without the full context.
    Buffer -> Bool
endsText :: Bool,
    -- ^ special handling of the end of text paragraph can be applied to this buffer.
    Buffer -> Bool
preserveDefaultIgnorables :: Bool,
    -- ^ character with Default_Ignorable Unicode property should use the
    -- corresponding glyph from the font, instead of hiding them (done by
    -- replacing them with the space glyph and zeroing the advance width.)
    -- Takes precedance over `removeDefaultIgnorables`.
    Buffer -> Bool
removeDefaultIgnorables :: Bool,
    -- ^ character with Default_Ignorable Unicode property should be removed
    -- from glyph string instead of hiding them (done by replacing them with
    -- the space glyph and zeroing the advance width.)
    Buffer -> Bool
don'tInsertDottedCircle :: Bool,
    -- ^ a dotted circle should not be inserted in the rendering of incorrect
    -- character sequences (such as <0905 093E>).
    Buffer -> ClusterLevel
clusterLevel :: ClusterLevel,
    -- ^ dictates one aspect of how HarfBuzz will treat non-base characters
    -- during shaping.
    Buffer -> Char
invisibleGlyph :: Char,
    -- ^ The glyph number that replaces invisible characters in the
    -- shaping result. If set to zero (default), the glyph for the U+0020
    -- SPACE character is used. Otherwise, this value is used verbatim.
    Buffer -> Char
replacementCodepoint :: Char,
    -- ^ the glyph number that replaces invalid entries for a given encoding
    -- when adding text to buffer.
    Buffer -> Char
notFoundGlyph :: Char
    -- ^ the glyph number that replaces replaces characters not found in the font.
  } deriving (Buffer -> Buffer -> Bool
(Buffer -> Buffer -> Bool)
-> (Buffer -> Buffer -> Bool) -> Eq Buffer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Buffer -> Buffer -> Bool
$c/= :: Buffer -> Buffer -> Bool
== :: Buffer -> Buffer -> Bool
$c== :: Buffer -> Buffer -> Bool
Eq, Int -> Buffer -> ShowS
[Buffer] -> ShowS
Buffer -> String
(Int -> Buffer -> ShowS)
-> (Buffer -> String) -> ([Buffer] -> ShowS) -> Show Buffer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Buffer] -> ShowS
$cshowList :: [Buffer] -> ShowS
show :: Buffer -> String
$cshow :: Buffer -> String
showsPrec :: Int -> Buffer -> ShowS
$cshowsPrec :: Int -> Buffer -> ShowS
Show, ReadPrec [Buffer]
ReadPrec Buffer
Int -> ReadS Buffer
ReadS [Buffer]
(Int -> ReadS Buffer)
-> ReadS [Buffer]
-> ReadPrec Buffer
-> ReadPrec [Buffer]
-> Read Buffer
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Buffer]
$creadListPrec :: ReadPrec [Buffer]
readPrec :: ReadPrec Buffer
$creadPrec :: ReadPrec Buffer
readList :: ReadS [Buffer]
$creadList :: ReadS [Buffer]
readsPrec :: Int -> ReadS Buffer
$creadsPrec :: Int -> ReadS Buffer
Read, Eq Buffer
Eq Buffer
-> (Buffer -> Buffer -> Ordering)
-> (Buffer -> Buffer -> Bool)
-> (Buffer -> Buffer -> Bool)
-> (Buffer -> Buffer -> Bool)
-> (Buffer -> Buffer -> Bool)
-> (Buffer -> Buffer -> Buffer)
-> (Buffer -> Buffer -> Buffer)
-> Ord Buffer
Buffer -> Buffer -> Bool
Buffer -> Buffer -> Ordering
Buffer -> Buffer -> Buffer
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
min :: Buffer -> Buffer -> Buffer
$cmin :: Buffer -> Buffer -> Buffer
max :: Buffer -> Buffer -> Buffer
$cmax :: Buffer -> Buffer -> Buffer
>= :: Buffer -> Buffer -> Bool
$c>= :: Buffer -> Buffer -> Bool
> :: Buffer -> Buffer -> Bool
$c> :: Buffer -> Buffer -> Bool
<= :: Buffer -> Buffer -> Bool
$c<= :: Buffer -> Buffer -> Bool
< :: Buffer -> Buffer -> Bool
$c< :: Buffer -> Buffer -> Bool
compare :: Buffer -> Buffer -> Ordering
$ccompare :: Buffer -> Buffer -> Ordering
Ord)

-- | Whether the given text is Unicode or font-specific "glyphs".
data ContentType = ContentTypeUnicode | ContentTypeGlyphs deriving (ContentType -> ContentType -> Bool
(ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool) -> Eq ContentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContentType -> ContentType -> Bool
$c/= :: ContentType -> ContentType -> Bool
== :: ContentType -> ContentType -> Bool
$c== :: ContentType -> ContentType -> Bool
Eq, Int -> ContentType -> ShowS
[ContentType] -> ShowS
ContentType -> String
(Int -> ContentType -> ShowS)
-> (ContentType -> String)
-> ([ContentType] -> ShowS)
-> Show ContentType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ContentType] -> ShowS
$cshowList :: [ContentType] -> ShowS
show :: ContentType -> String
$cshow :: ContentType -> String
showsPrec :: Int -> ContentType -> ShowS
$cshowsPrec :: Int -> ContentType -> ShowS
Show, ReadPrec [ContentType]
ReadPrec ContentType
Int -> ReadS ContentType
ReadS [ContentType]
(Int -> ReadS ContentType)
-> ReadS [ContentType]
-> ReadPrec ContentType
-> ReadPrec [ContentType]
-> Read ContentType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ContentType]
$creadListPrec :: ReadPrec [ContentType]
readPrec :: ReadPrec ContentType
$creadPrec :: ReadPrec ContentType
readList :: ReadS [ContentType]
$creadList :: ReadS [ContentType]
readsPrec :: Int -> ReadS ContentType
$creadsPrec :: Int -> ReadS ContentType
Read, Eq ContentType
Eq ContentType
-> (ContentType -> ContentType -> Ordering)
-> (ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> Bool)
-> (ContentType -> ContentType -> ContentType)
-> (ContentType -> ContentType -> ContentType)
-> Ord ContentType
ContentType -> ContentType -> Bool
ContentType -> ContentType -> Ordering
ContentType -> ContentType -> ContentType
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
min :: ContentType -> ContentType -> ContentType
$cmin :: ContentType -> ContentType -> ContentType
max :: ContentType -> ContentType -> ContentType
$cmax :: ContentType -> ContentType -> ContentType
>= :: ContentType -> ContentType -> Bool
$c>= :: ContentType -> ContentType -> Bool
> :: ContentType -> ContentType -> Bool
$c> :: ContentType -> ContentType -> Bool
<= :: ContentType -> ContentType -> Bool
$c<= :: ContentType -> ContentType -> Bool
< :: ContentType -> ContentType -> Bool
$c< :: ContentType -> ContentType -> Bool
compare :: ContentType -> ContentType -> Ordering
$ccompare :: ContentType -> ContentType -> Ordering
Ord)
-- | Defines how fine the groupings represented by `GlyphInfo`'s `cluster` property are.`
data ClusterLevel = ClusterMonotoneGraphemes | ClusterMonotoneChars | ClusterChars
    deriving (ClusterLevel -> ClusterLevel -> Bool
(ClusterLevel -> ClusterLevel -> Bool)
-> (ClusterLevel -> ClusterLevel -> Bool) -> Eq ClusterLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClusterLevel -> ClusterLevel -> Bool
$c/= :: ClusterLevel -> ClusterLevel -> Bool
== :: ClusterLevel -> ClusterLevel -> Bool
$c== :: ClusterLevel -> ClusterLevel -> Bool
Eq, Int -> ClusterLevel -> ShowS
[ClusterLevel] -> ShowS
ClusterLevel -> String
(Int -> ClusterLevel -> ShowS)
-> (ClusterLevel -> String)
-> ([ClusterLevel] -> ShowS)
-> Show ClusterLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClusterLevel] -> ShowS
$cshowList :: [ClusterLevel] -> ShowS
show :: ClusterLevel -> String
$cshow :: ClusterLevel -> String
showsPrec :: Int -> ClusterLevel -> ShowS
$cshowsPrec :: Int -> ClusterLevel -> ShowS
Show, ReadPrec [ClusterLevel]
ReadPrec ClusterLevel
Int -> ReadS ClusterLevel
ReadS [ClusterLevel]
(Int -> ReadS ClusterLevel)
-> ReadS [ClusterLevel]
-> ReadPrec ClusterLevel
-> ReadPrec [ClusterLevel]
-> Read ClusterLevel
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ClusterLevel]
$creadListPrec :: ReadPrec [ClusterLevel]
readPrec :: ReadPrec ClusterLevel
$creadPrec :: ReadPrec ClusterLevel
readList :: ReadS [ClusterLevel]
$creadList :: ReadS [ClusterLevel]
readsPrec :: Int -> ReadS ClusterLevel
$creadsPrec :: Int -> ReadS ClusterLevel
Read, Eq ClusterLevel
Eq ClusterLevel
-> (ClusterLevel -> ClusterLevel -> Ordering)
-> (ClusterLevel -> ClusterLevel -> Bool)
-> (ClusterLevel -> ClusterLevel -> Bool)
-> (ClusterLevel -> ClusterLevel -> Bool)
-> (ClusterLevel -> ClusterLevel -> Bool)
-> (ClusterLevel -> ClusterLevel -> ClusterLevel)
-> (ClusterLevel -> ClusterLevel -> ClusterLevel)
-> Ord ClusterLevel
ClusterLevel -> ClusterLevel -> Bool
ClusterLevel -> ClusterLevel -> Ordering
ClusterLevel -> ClusterLevel -> ClusterLevel
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
min :: ClusterLevel -> ClusterLevel -> ClusterLevel
$cmin :: ClusterLevel -> ClusterLevel -> ClusterLevel
max :: ClusterLevel -> ClusterLevel -> ClusterLevel
$cmax :: ClusterLevel -> ClusterLevel -> ClusterLevel
>= :: ClusterLevel -> ClusterLevel -> Bool
$c>= :: ClusterLevel -> ClusterLevel -> Bool
> :: ClusterLevel -> ClusterLevel -> Bool
$c> :: ClusterLevel -> ClusterLevel -> Bool
<= :: ClusterLevel -> ClusterLevel -> Bool
$c<= :: ClusterLevel -> ClusterLevel -> Bool
< :: ClusterLevel -> ClusterLevel -> Bool
$c< :: ClusterLevel -> ClusterLevel -> Bool
compare :: ClusterLevel -> ClusterLevel -> Ordering
$ccompare :: ClusterLevel -> ClusterLevel -> Ordering
Ord)

-- | An empty buffer with sensible default properties.
defaultBuffer :: Buffer
defaultBuffer = Buffer :: Text
-> Maybe ContentType
-> Maybe Direction
-> Maybe String
-> Maybe String
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> ClusterLevel
-> Char
-> Char
-> Char
-> Buffer
Buffer {
        text :: Text
text = Text
Lazy.empty,
        contentType :: Maybe ContentType
contentType = ContentType -> Maybe ContentType
forall a. a -> Maybe a
Just ContentType
ContentTypeUnicode,
        direction :: Maybe Direction
direction = Maybe Direction
forall a. Maybe a
Nothing,
        script :: Maybe String
script = Maybe String
forall a. Maybe a
Nothing,
        language :: Maybe String
language = Maybe String
forall a. Maybe a
Nothing,
        beginsText :: Bool
beginsText = Bool
True,
        endsText :: Bool
endsText = Bool
True,
        preserveDefaultIgnorables :: Bool
preserveDefaultIgnorables = Bool
False,
        removeDefaultIgnorables :: Bool
removeDefaultIgnorables = Bool
False,
        don'tInsertDottedCircle :: Bool
don'tInsertDottedCircle = Bool
False,
        clusterLevel :: ClusterLevel
clusterLevel = ClusterLevel
ClusterMonotoneGraphemes,
        invisibleGlyph :: Char
invisibleGlyph = Char
' ',
        replacementCodepoint :: Char
replacementCodepoint = Char
'\xFFFD',
        notFoundGlyph :: Char
notFoundGlyph = Char
'\0'
    }

------
--- Directions
------

-- | The direction of a text segment or buffer.
data Direction = DirLTR | DirRTL | DirTTB | DirBTT deriving (Direction -> Direction -> Bool
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq, Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show, ReadPrec [Direction]
ReadPrec Direction
Int -> ReadS Direction
ReadS [Direction]
(Int -> ReadS Direction)
-> ReadS [Direction]
-> ReadPrec Direction
-> ReadPrec [Direction]
-> Read Direction
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Direction]
$creadListPrec :: ReadPrec [Direction]
readPrec :: ReadPrec Direction
$creadPrec :: ReadPrec Direction
readList :: ReadS [Direction]
$creadList :: ReadS [Direction]
readsPrec :: Int -> ReadS Direction
$creadsPrec :: Int -> ReadS Direction
Read, Eq Direction
Eq Direction
-> (Direction -> Direction -> Ordering)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Direction)
-> (Direction -> Direction -> Direction)
-> Ord Direction
Direction -> Direction -> Bool
Direction -> Direction -> Ordering
Direction -> Direction -> Direction
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
min :: Direction -> Direction -> Direction
$cmin :: Direction -> Direction -> Direction
max :: Direction -> Direction -> Direction
$cmax :: Direction -> Direction -> Direction
>= :: Direction -> Direction -> Bool
$c>= :: Direction -> Direction -> Bool
> :: Direction -> Direction -> Bool
$c> :: Direction -> Direction -> Bool
<= :: Direction -> Direction -> Bool
$c<= :: Direction -> Direction -> Bool
< :: Direction -> Direction -> Bool
$c< :: Direction -> Direction -> Bool
compare :: Direction -> Direction -> Ordering
$ccompare :: Direction -> Direction -> Ordering
Ord)
-- | Converts a string to an `Direction`.
-- Matching is loose and applies only to the first letter. For examples, 
-- "LTR" and "left-to-right" will both return HB_DIRECTION_LTR.
dirFromStr :: String -> Maybe Direction
dirFromStr (Char
'L':String
_) = Direction -> Maybe Direction
forall a. a -> Maybe a
Just Direction
DirLTR
dirFromStr (Char
'l':String
_) = Direction -> Maybe Direction
forall a. a -> Maybe a
Just Direction
DirLTR
dirFromStr (Char
'R':String
_) = Direction -> Maybe Direction
forall a. a -> Maybe a
Just Direction
DirRTL
dirFromStr (Char
'r':String
_) = Direction -> Maybe Direction
forall a. a -> Maybe a
Just Direction
DirRTL
dirFromStr (Char
'T':String
_) = Direction -> Maybe Direction
forall a. a -> Maybe a
Just Direction
DirTTB
dirFromStr (Char
't':String
_) = Direction -> Maybe Direction
forall a. a -> Maybe a
Just Direction
DirTTB
dirFromStr (Char
'B':String
_) = Direction -> Maybe Direction
forall a. a -> Maybe a
Just Direction
DirBTT
dirFromStr (Char
'b':String
_) = Direction -> Maybe Direction
forall a. a -> Maybe a
Just Direction
DirBTT
dirFromStr String
_ = Maybe Direction
forall a. Maybe a
Nothing
-- | Converts an `Direction` to a string.
dirToStr :: Direction -> String
dirToStr Direction
DirLTR = String
"ltr"
dirToStr Direction
DirRTL = String
"rtl"
dirToStr Direction
DirTTB = String
"ttb"
dirToStr Direction
DirBTT = String
"btt"
-- | Reverses a text direction.
dirReverse :: Direction -> Direction
dirReverse Direction
DirLTR = Direction
DirRTL
dirReverse Direction
DirRTL = Direction
DirLTR
dirReverse Direction
DirTTB = Direction
DirBTT
dirReverse Direction
DirBTT = Direction
DirTTB
-- | Tests whether a text direction moves backward
-- (from right to left, or from bottom to top).
dirBackward :: Direction -> Bool
dirBackward Direction
dir = Direction
dir Direction -> [Direction] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` [Direction
DirRTL, Direction
DirBTT]
-- | Tests whether a text direction moves forward
-- (from left to right, or from top to bottom).
dirForward :: Direction -> Bool
dirForward Direction
dir = Direction
dir Direction -> [Direction] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` [Direction
DirLTR, Direction
DirTTB]
-- | Tests whether a text direction is horizontal.
dirHorizontal :: Direction -> Bool
dirHorizontal Direction
dir = Direction
dir Direction -> [Direction] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` [Direction
DirLTR, Direction
DirRTL]
-- | Tests whether a text direction is vertical.
dirVertical :: Direction -> Bool
dirVertical Direction
dir = Direction
dir Direction -> [Direction] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`Prelude.elem` [Direction
DirTTB, Direction
DirBTT]

-- | Converts a `Direction` to C encoding.
dir2int :: Maybe Direction -> p
dir2int Maybe Direction
Nothing = p
0
dir2int (Just Direction
DirLTR) = p
4
dir2int (Just Direction
DirRTL) = p
5
dir2int (Just Direction
DirTTB) = p
6
dir2int (Just Direction
DirBTT) = p
7
-- | Sets `direction` property on C `Buffer'` struct.
foreign import ccall "hb_buffer_set_direction" hb_buffer_set_direction
    :: Buffer' -> Int -> IO ()

-- | Converts a `Direction` from C encoding.
int2dir :: a -> Maybe Direction
int2dir a
4 = Direction -> Maybe Direction
forall a. a -> Maybe a
Just Direction
DirLTR
int2dir a
5 = Direction -> Maybe Direction
forall a. a -> Maybe a
Just Direction
DirRTL
int2dir a
6 = Direction -> Maybe Direction
forall a. a -> Maybe a
Just Direction
DirTTB
int2dir a
7 = Direction -> Maybe Direction
forall a. a -> Maybe a
Just Direction
DirBTT
int2dir a
_ = Maybe Direction
forall a. Maybe a
Nothing

-- | Fetches the `Direction` of a script when it is set horizontally.
-- All right-to-left scripts will return `DirRTL`.
-- All left-to-right scripts will return `DirLTR`.
-- Scripts that can be written either horizontally or vertically will return `Nothing`.
-- Unknown scripts will return `DirLTR`.
scriptHorizontalDir :: String -> Maybe Direction
scriptHorizontalDir :: String -> Maybe Direction
scriptHorizontalDir = Int -> Maybe Direction
forall {a}. (Eq a, Num a) => a -> Maybe Direction
int2dir (Int -> Maybe Direction)
-> (String -> Int) -> String -> Maybe Direction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
hb_script_get_horizontal_direction (Word32 -> Int) -> (String -> Word32) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Word32
script_from_string
foreign import ccall "hb_script_get_horizontal_direction" hb_script_get_horizontal_direction
    :: Word32 -> Int

------
--- Locales
------
data Language'
-- | Represents a natural written language.
-- Corresponds to a BCP47 language tag.
type Language = Ptr Language'
-- | Fetch the default language from current locale.
-- NOTE that the first time this function is called, it calls (C code)
-- "setlocale (LC_CTYPE, nullptr)" to fetch current locale.
-- The underlying setlocale function is, in many implementations, NOT threadsafe.
-- To avoid problems, call this function once before multiple threads can call it.
-- This function may be used to fill in missing fields on a `Buffer`.
languageDefault :: IO String
languageDefault :: IO String
languageDefault = IO Language
hb_language_get_default IO Language -> (Language -> IO CString) -> IO CString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Language -> IO CString
hb_language_to_string IO CString -> (CString -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CString -> IO String
peekCString
foreign import ccall "hb_language_to_string" hb_language_to_string :: Language -> IO CString
foreign import ccall "hb_language_get_default" hb_language_get_default :: IO Language

-- | Converts a `String` representing a BCP 47 language tag to the corresponding `Language`.
hb_language_from_string :: String -> IO Language
hb_language_from_string :: String -> IO Language
hb_language_from_string String
str =
    String -> (CString -> IO Language) -> IO Language
forall a. String -> (CString -> IO a) -> IO a
withCString String
str ((CString -> IO Language) -> IO Language)
-> (CString -> IO Language) -> IO Language
forall a b. (a -> b) -> a -> b
$ \CString
str' -> CString -> Int -> IO Language
hb_language_from_string' CString
str' (-Int
1)
foreign import ccall "hb_language_from_string" hb_language_from_string'
    :: CString -> Int -> IO Language

{-
-- | Check whether a second language tag is the same or a more specific version
-- of the provided language tag.
-- For example, "fa_IR.utf8" is a more specific tag for "fa" or for "fa_IR".
languageMatches :: String -> String -> Bool
languageMatches lang specific = unsafePerformIO $ do
    lang' <- hb_language_from_string lang
    specific' <- hb_language_from_string specific
    hb_language_matches lang' specific'
foreign import ccall "hb_language_matches" hb_language_matches :: Language -> Language -> IO Bool-}

------
--- FFI Support
------

-- | Directly corresponds to "hb_buffer_t".
data Buffer''
type Buffer' = Ptr Buffer''

-- | Temporarily allocates a `Buffer'`
withNewBuffer :: (Buffer' -> IO a) -> IO a
withNewBuffer :: forall a. (Buffer' -> IO a) -> IO a
withNewBuffer Buffer' -> IO a
cb = IO Buffer' -> (Buffer' -> IO ()) -> (Buffer' -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Buffer'
hb_buffer_create Buffer' -> IO ()
hb_buffer_destroy Buffer' -> IO a
cb
foreign import ccall "hb_buffer_create" hb_buffer_create :: IO Buffer'
foreign import ccall "hb_buffer_destroy" hb_buffer_destroy :: Buffer' -> IO ()

-- | Decodes given lazy `Text` into given `Buffer'`.
-- Should be valid Unicode data.
-- Captures a few trailing & preceding chars when possible to give additional
-- context to the shaping.
bufferWithText :: Buffer' -> Text -> IO b -> IO b
bufferWithText Buffer'
_ Text
Lazy.Empty IO b
cb = IO b
cb
bufferWithText Buffer'
buffer txt :: Text
txt@(Lazy.Chunk (Txt.Text (A.ByteArray ByteArray#
arr) Int
offset Int
length) Text
txts) IO b
cb = do
    Buffer' -> ByteArray# -> Int# -> Word -> Int -> IO ()
hb_buffer_add_utf8 Buffer'
buffer ByteArray#
arr (ByteArray# -> Int#
sizeofByteArray# ByteArray#
arr) (Int -> Word
forall a. Enum a => Int -> a
toEnum Int
offset) Int
length
    Buffer' -> Text -> IO b -> IO b
bufferWithText Buffer'
buffer Text
txts IO b
cb
foreign import ccall "hb_buffer_add_utf8" hb_buffer_add_utf8
    :: Buffer' -> ByteArray# -> Int# -> Word -> Int -> IO ()

-- | Converts initial char to uppercase & all others to lowercase.
-- Internal utility for reimplementation `script_from_string`.
titlecase :: String -> String
titlecase :: ShowS
titlecase String
"" = String
""
titlecase (Char
c:String
cs) = Char -> Char
toUpper Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
Prelude.map Char -> Char
toLower String
cs
-- | Converts a string str representing an ISO 15924 script tag to a corresponding "tag" `Word32`.
script_from_string :: String -> Word32
script_from_string :: String -> Word32
script_from_string String
str = String -> Word32
tag_from_string (String -> Word32) -> String -> Word32
forall a b. (a -> b) -> a -> b
$ case ShowS
titlecase String
str of
    Char
'Q':Char
'a':Char
'a':Char
'i':String
_ -> String
"Zinh"
    Char
'Q':Char
'a':Char
'a':Char
'c':String
_ -> String
"Copt"

    Char
'A':Char
'r':Char
'a':Char
'n':String
_ -> String
"Arab"
    Char
'C':Char
'y':Char
'r':Char
's':String
_ -> String
"Cyrl"
    Char
'G':Char
'e':Char
'o':Char
'k':String
_ -> String
"Geor"
    Char
'H':Char
'a':Char
'n':Char
's':String
_ -> String
"Hani"
    Char
'H':Char
'a':Char
'n':Char
't':String
_ -> String
"Hani"
    Char
'J':Char
'a':Char
'm':Char
'o':String
_ -> String
"Hang"
    Char
'L':Char
'a':Char
't':Char
'f':String
_ -> String
"Latn"
    Char
'L':Char
'a':Char
't':Char
'g':String
_ -> String
"Latn"
    Char
'S':Char
'y':Char
'r':Char
'e':String
_ -> String
"Syrc"
    Char
'S':Char
'y':Char
'r':Char
'j':String
_ -> String
"Syrc"
    Char
'S':Char
'y':Char
'r':Char
'n':String
_ -> String
"Syrc"
    String
x -> String
x
-- | Converts a `String` into a "tag" `Word32`. Valid tags are 4 `Char`s.
-- Shorter input `String`s will be padded with spaces.
-- Longer input strings will be truncated.
tag_from_string :: String -> Word32
tag_from_string :: String -> Word32
tag_from_string String
str = case String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
Prelude.repeat Char
' ' of
    Char
c1:Char
c2:Char
c3:Char
c4:String
_ -> (Word32 -> Word32 -> Word32) -> Word32 -> [Word32] -> Word32
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
(.|.) Word32
0 [
        Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL (Char -> Word32
c2w Char
c1 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7f) Int
24,
        Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL (Char -> Word32
c2w Char
c2 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7f) Int
16,
        Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL (Char -> Word32
c2w Char
c3 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7f) Int
8,
        Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL (Char -> Word32
c2w Char
c4 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7f) Int
0
      ]
    String
_ -> Word32
0
-- | Converts a "tag" `Word32` into a 4 `Char` `String`.
tag_to_string :: Word32 -> String
tag_to_string :: Word32 -> String
tag_to_string Word32
tag = [
    Word32 -> Char
w2c (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
tag Int
24 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7f),
    Word32 -> Char
w2c (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
tag Int
16 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7f),
    Word32 -> Char
w2c (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
tag Int
8 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7f),
    Word32 -> Char
w2c (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
tag Int
0 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7f)
  ]

c2w :: Char -> Word32
c2w :: Char -> Word32
c2w = Int -> Word32
forall a. Enum a => Int -> a
toEnum (Int -> Word32) -> (Char -> Int) -> Char -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum
w2c :: Word32 -> Char
w2c :: Word32 -> Char
w2c = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Word32 -> Int) -> Word32 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a. Enum a => a -> Int
fromEnum

------
--- Haskell-to-C conversion
------

-- | Temporarily allocates a `Buffer'` corresponding to the given `Buffer`
-- to be processed entirely within the given callback.
withBuffer :: Buffer -> (Buffer' -> IO a) -> IO a
withBuffer :: forall a. Buffer -> (Buffer' -> IO a) -> IO a
withBuffer Buffer
buf Buffer' -> IO a
cb = (Buffer' -> IO a) -> IO a
forall a. (Buffer' -> IO a) -> IO a
withNewBuffer ((Buffer' -> IO a) -> IO a) -> (Buffer' -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Buffer'
buf' -> Buffer' -> Text -> IO a -> IO a
forall {b}. Buffer' -> Text -> IO b -> IO b
bufferWithText Buffer'
buf' (Buffer -> Text
text Buffer
buf) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    Buffer' -> Int -> IO ()
hb_buffer_set_content_type Buffer'
buf' (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ case Buffer -> Maybe ContentType
contentType Buffer
buf of
        Maybe ContentType
Nothing -> Int
0
        Just ContentType
ContentTypeUnicode -> Int
1
        Just ContentType
ContentTypeGlyphs -> Int
2
    Buffer' -> Int -> IO ()
hb_buffer_set_direction Buffer'
buf' (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Direction -> Int
forall {p}. Num p => Maybe Direction -> p
dir2int (Maybe Direction -> Int) -> Maybe Direction -> Int
forall a b. (a -> b) -> a -> b
$ Buffer -> Maybe Direction
direction Buffer
buf
    case Buffer -> Maybe String
script Buffer
buf of
        Just String
script' -> Buffer' -> Word32 -> IO ()
hb_buffer_set_script Buffer'
buf' (Word32 -> IO ()) -> Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Word32
script_from_string String
script'
        Maybe String
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case Buffer -> Maybe String
language Buffer
buf of
        Just String
lang' -> Buffer' -> Language -> IO ()
hb_buffer_set_language Buffer'
buf' (Language -> IO ()) -> IO Language -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO Language
hb_language_from_string String
lang'
        Maybe String
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Buffer' -> Int -> IO ()
hb_buffer_set_flags Buffer'
buf' (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl Int -> Int -> Int
forall a. Bits a => a -> a -> a
(.|.) Int
0 [
        if Buffer -> Bool
beginsText Buffer
buf then Int
1 else Int
0,
        if Buffer -> Bool
endsText Buffer
buf then Int
2 else Int
0,
        if Buffer -> Bool
preserveDefaultIgnorables Buffer
buf then Int
4 else Int
0,
        if Buffer -> Bool
removeDefaultIgnorables Buffer
buf then Int
8 else Int
0,
        if Buffer -> Bool
don'tInsertDottedCircle Buffer
buf then Int
16 else Int
0
      ]
    Buffer' -> Int -> IO ()
hb_buffer_set_cluster_level Buffer'
buf' (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ case Buffer -> ClusterLevel
clusterLevel Buffer
buf of
        ClusterLevel
ClusterMonotoneGraphemes -> Int
0
        ClusterLevel
ClusterMonotoneChars -> Int
1
        ClusterLevel
ClusterChars -> Int
2
    Buffer' -> Word32 -> IO ()
hb_buffer_set_invisible_glyph Buffer'
buf' (Word32 -> IO ()) -> Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ Char -> Word32
c2w (Char -> Word32) -> Char -> Word32
forall a b. (a -> b) -> a -> b
$ Buffer -> Char
invisibleGlyph Buffer
buf
    Buffer' -> Word32 -> IO ()
hb_buffer_set_replacement_codepoint Buffer'
buf' (Word32 -> IO ()) -> Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ Char -> Word32
c2w (Char -> Word32) -> Char -> Word32
forall a b. (a -> b) -> a -> b
$ Buffer -> Char
replacementCodepoint Buffer
buf
    Buffer' -> Word32 -> IO ()
hb_buffer_set_not_found_glyph Buffer'
buf' (Word32 -> IO ()) -> Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ Char -> Word32
c2w (Char -> Word32) -> Char -> Word32
forall a b. (a -> b) -> a -> b
$ Buffer -> Char
notFoundGlyph Buffer
buf
    case (Buffer -> Maybe ContentType
contentType Buffer
buf, Buffer -> Maybe Direction
direction Buffer
buf, Buffer -> Maybe String
script Buffer
buf, Buffer -> Maybe String
language Buffer
buf) of
        (Just ContentType
ContentTypeUnicode, Maybe Direction
Nothing, Maybe String
_, Maybe String
_) -> Buffer' -> IO ()
hb_buffer_guess_segment_properties Buffer'
buf'
        (Just ContentType
ContentTypeUnicode, Maybe Direction
_, Maybe String
Nothing, Maybe String
_) -> Buffer' -> IO ()
hb_buffer_guess_segment_properties Buffer'
buf'
        (Just ContentType
ContentTypeUnicode, Maybe Direction
_, Maybe String
_, Maybe String
Nothing) -> Buffer' -> IO ()
hb_buffer_guess_segment_properties Buffer'
buf'
        (Maybe ContentType, Maybe Direction, Maybe String, Maybe String)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    IO Bool -> IO ()
throwFalse (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Buffer' -> IO Bool
hb_buffer_allocation_successful Buffer'
buf'
    Buffer' -> IO a
cb Buffer'
buf'
foreign import ccall "hb_buffer_set_content_type" hb_buffer_set_content_type
    :: Buffer' -> Int -> IO ()
foreign import ccall "hb_buffer_set_script" hb_buffer_set_script
    :: Buffer' -> Word32 -> IO ()
foreign import ccall "hb_buffer_set_language" hb_buffer_set_language
    :: Buffer' -> Language -> IO ()
foreign import ccall "hb_buffer_set_flags" hb_buffer_set_flags :: Buffer' -> Int -> IO ()
foreign import ccall "hb_buffer_set_cluster_level" hb_buffer_set_cluster_level
    :: Buffer' -> Int -> IO ()
foreign import ccall "hb_buffer_set_invisible_glyph" hb_buffer_set_invisible_glyph
    :: Buffer' -> Word32 -> IO ()
foreign import ccall "hb_buffer_set_replacement_codepoint" hb_buffer_set_replacement_codepoint
    :: Buffer' -> Word32 -> IO ()
foreign import ccall "hb_buffer_set_not_found_glyph" hb_buffer_set_not_found_glyph
    :: Buffer' -> Word32 -> IO ()
foreign import ccall "hb_buffer_guess_segment_properties" hb_buffer_guess_segment_properties
    :: Buffer' -> IO ()
foreign import ccall "hb_buffer_allocation_successful" hb_buffer_allocation_successful
    :: Buffer' -> IO Bool

------
--- C-to-Haskell conversion
------

-- | Holds information about the glyphs & their relation to input text.
data GlyphInfo = GlyphInfo {
    GlyphInfo -> Word32
codepoint :: Word32,
    -- ^ Glyph index (or unicode codepoint)
    GlyphInfo -> Word32
cluster :: Word32,
    -- ^ The index of the character in the original text that corresponds to
    -- this `GlyphInfo`. More than one `GlyphInfo` may have the same `cluster`
    -- value if they resulted from the same character, & when more than one
    -- character gets merged into the same glyph `GlyphInfo` will have the
    -- smallest cluster value of them.
    -- By default some characters are merged into the same cluster even when
    -- they are seperate glyphs, `Buffer`'s `clusterLevel` property allows
    -- selecting more fine grained cluster handling.
    GlyphInfo -> Bool
unsafeToBreak :: Bool,
    -- ^ Indicates that if input text is broken at the beginning of the cluster
    -- this glyph is part of, then both sides need to be re-shaped,
    -- as the result might be different.
    -- On the flip side, it means that when this flag is not present,
    -- then it is safe to break the glyph-run at the beginning of this cluster,
    -- and the two sides will represent the exact same result one would get
    -- if breaking input text at the beginning of this cluster and shaping
    -- the two sides separately. This can be used to optimize paragraph layout,
    -- by avoiding re-shaping of each line after line-breaking.
    GlyphInfo -> Bool
unsafeToConcat :: Bool,
    -- ^ Indicates that if input text is changed on one side of the beginning
    -- of the cluster this glyph is part of, then the shaping results for
    -- the other side might change.
    -- Note that the absence of this flag will NOT by itself mean that
    -- it IS safe to concat text. Only two pieces of text both of which
    -- clear of this flag can be concatenated safely.
    -- See https://harfbuzz.github.io/harfbuzz-hb-buffer.html#HB_GLYPH_FLAG_UNSAFE_TO_CONCAT
    -- for more details.
    GlyphInfo -> Bool
safeToInsertTatweel :: Bool
    -- ^ In scripts that use elongation (Arabic, Mongolian, Syriac, etc.),
    -- this flag signifies that it is safe to insert a U+0640 TATWEEL character
    -- before this cluster for elongation.
    -- This flag does not determine the script-specific elongation places,
    -- but only when it is safe to do the elongation without interrupting text shaping.
} deriving (Int -> GlyphInfo -> ShowS
[GlyphInfo] -> ShowS
GlyphInfo -> String
(Int -> GlyphInfo -> ShowS)
-> (GlyphInfo -> String)
-> ([GlyphInfo] -> ShowS)
-> Show GlyphInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GlyphInfo] -> ShowS
$cshowList :: [GlyphInfo] -> ShowS
show :: GlyphInfo -> String
$cshow :: GlyphInfo -> String
showsPrec :: Int -> GlyphInfo -> ShowS
$cshowsPrec :: Int -> GlyphInfo -> ShowS
Show, ReadPrec [GlyphInfo]
ReadPrec GlyphInfo
Int -> ReadS GlyphInfo
ReadS [GlyphInfo]
(Int -> ReadS GlyphInfo)
-> ReadS [GlyphInfo]
-> ReadPrec GlyphInfo
-> ReadPrec [GlyphInfo]
-> Read GlyphInfo
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [GlyphInfo]
$creadListPrec :: ReadPrec [GlyphInfo]
readPrec :: ReadPrec GlyphInfo
$creadPrec :: ReadPrec GlyphInfo
readList :: ReadS [GlyphInfo]
$creadList :: ReadS [GlyphInfo]
readsPrec :: Int -> ReadS GlyphInfo
$creadsPrec :: Int -> ReadS GlyphInfo
Read, GlyphInfo -> GlyphInfo -> Bool
(GlyphInfo -> GlyphInfo -> Bool)
-> (GlyphInfo -> GlyphInfo -> Bool) -> Eq GlyphInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GlyphInfo -> GlyphInfo -> Bool
$c/= :: GlyphInfo -> GlyphInfo -> Bool
== :: GlyphInfo -> GlyphInfo -> Bool
$c== :: GlyphInfo -> GlyphInfo -> Bool
Eq)
instance Storable GlyphInfo where
    sizeOf :: GlyphInfo -> Int
sizeOf GlyphInfo
_ = Word32 -> Int
forall a. Storable a => a -> Int
sizeOf (Word32
forall a. HasCallStack => a
undefined :: Word32) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
5
    alignment :: GlyphInfo -> Int
alignment GlyphInfo
_ = Word32 -> Int
forall a. Storable a => a -> Int
alignment (Word32
forall a. HasCallStack => a
undefined :: Word32)
    peek :: Ptr GlyphInfo -> IO GlyphInfo
peek Ptr GlyphInfo
ptr = do
        let ptr' :: Ptr Word32
            ptr' :: Ptr Word32
ptr' = Ptr GlyphInfo -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr GlyphInfo
ptr
        -- Ignore private fields.
        Word32
codepoint' <- Ptr Word32
ptr' Ptr Word32 -> Int -> IO Word32
forall a. Storable a => Ptr a -> Int -> IO a
`peekElemOff` Int
0
        Word32
mask <- Ptr Word32
ptr' Ptr Word32 -> Int -> IO Word32
forall a. Storable a => Ptr a -> Int -> IO a
`peekElemOff` Int
1
        Word32
cluster' <- Ptr Word32
ptr' Ptr Word32 -> Int -> IO Word32
forall a. Storable a => Ptr a -> Int -> IO a
`peekElemOff` Int
2
        GlyphInfo -> IO GlyphInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (GlyphInfo -> IO GlyphInfo) -> GlyphInfo -> IO GlyphInfo
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> Bool -> Bool -> Bool -> GlyphInfo
GlyphInfo Word32
codepoint' Word32
cluster' (Word32
mask Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
1) (Word32
mask Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
2) (Word32
mask Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
3)
    poke :: Ptr GlyphInfo -> GlyphInfo -> IO ()
poke Ptr GlyphInfo
ptr (GlyphInfo Word32
codepoint' Word32
cluster' Bool
flag1 Bool
flag2 Bool
flag3) = do
        -- Zero private fields.
        let ptr' :: Ptr Word32
            ptr' :: Ptr Word32
ptr' = Ptr GlyphInfo -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr GlyphInfo
ptr
        Ptr Word32 -> Int -> Word32 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word32
ptr' Int
0 Word32
codepoint'
        Ptr Word32 -> Int -> Word32 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word32
ptr' Int
1 (Word32 -> IO ()) -> Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ (Word32 -> Word32 -> Word32) -> Word32 -> [Word32] -> Word32
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
(.|.) Word32
0 [
            if Bool
flag1 then Word32
1 else Word32
0,
            if Bool
flag2 then Word32
2 else Word32
0,
            if Bool
flag3 then Word32
4 else Word32
0
          ]
        Ptr Word32 -> Int -> Word32 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word32
ptr' Int
2 Word32
cluster'
        Ptr Word32 -> Int -> Word32 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word32
ptr' Int
3 Word32
0
        Ptr Word32 -> Int -> Word32 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word32
ptr' Int
4 Word32
0
-- | Decodes `Buffer'`'s glyph information array.'
glyphInfos :: Buffer' -> IO [GlyphInfo]
glyphInfos Buffer'
buf' = do
    Ptr GlyphInfo
arr <- IO (Ptr GlyphInfo) -> IO (Ptr GlyphInfo)
forall a. IO (Ptr a) -> IO (Ptr a)
throwNull (IO (Ptr GlyphInfo) -> IO (Ptr GlyphInfo))
-> IO (Ptr GlyphInfo) -> IO (Ptr GlyphInfo)
forall a b. (a -> b) -> a -> b
$ Buffer' -> Ptr Word -> IO (Ptr GlyphInfo)
hb_buffer_get_glyph_infos Buffer'
buf' Ptr Word
forall a. Ptr a
nullPtr
    Word
length <- Buffer' -> IO Word
hb_buffer_get_length Buffer'
buf'
    if Word
length Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0 Bool -> Bool -> Bool
|| Ptr GlyphInfo
arr Ptr GlyphInfo -> Ptr GlyphInfo -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr GlyphInfo
forall a. Ptr a
nullPtr
    then [GlyphInfo] -> IO [GlyphInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else [Int] -> (Int -> IO GlyphInfo) -> IO [GlyphInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0..Word -> Int
forall a. Enum a => a -> Int
fromEnum Word
length Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> IO GlyphInfo) -> IO [GlyphInfo])
-> (Int -> IO GlyphInfo) -> IO [GlyphInfo]
forall a b. (a -> b) -> a -> b
$ Ptr GlyphInfo -> Int -> IO GlyphInfo
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr GlyphInfo
arr
foreign import ccall "hb_buffer_get_glyph_infos" hb_buffer_get_glyph_infos
    :: Buffer' -> Ptr Word -> IO (Ptr GlyphInfo)
foreign import ccall "hb_buffer_get_length" hb_buffer_get_length :: Buffer' -> IO Word
-- NOTE: The array returned from FFI is valid as long as the buffer is.

-- | Holds positions of the glyph in both horizontal & vertical directions.
-- All positions are relative to current point.
data GlyphPos = GlyphPos {
    GlyphPos -> Int32
x_advance :: Int32,
    -- ^ How much the line advances after drawing this glyph when setting text
    -- in horizontal direction.
    GlyphPos -> Int32
y_advance :: Int32,
    -- ^ How much the line advances after drawing this glyph when setting text
    -- in vertical direction.
    GlyphPos -> Int32
x_offset :: Int32,
    -- ^ How much the glyph moves on the X-axis before drawing it, this should
    -- not effect how much the line advances.
    GlyphPos -> Int32
y_offset :: Int32
    -- ^ How much the glyph moves on the Y-axis before drawing it, this should
    -- not effect how much the line advances.
} deriving (Int -> GlyphPos -> ShowS
[GlyphPos] -> ShowS
GlyphPos -> String
(Int -> GlyphPos -> ShowS)
-> (GlyphPos -> String) -> ([GlyphPos] -> ShowS) -> Show GlyphPos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GlyphPos] -> ShowS
$cshowList :: [GlyphPos] -> ShowS
show :: GlyphPos -> String
$cshow :: GlyphPos -> String
showsPrec :: Int -> GlyphPos -> ShowS
$cshowsPrec :: Int -> GlyphPos -> ShowS
Show, ReadPrec [GlyphPos]
ReadPrec GlyphPos
Int -> ReadS GlyphPos
ReadS [GlyphPos]
(Int -> ReadS GlyphPos)
-> ReadS [GlyphPos]
-> ReadPrec GlyphPos
-> ReadPrec [GlyphPos]
-> Read GlyphPos
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [GlyphPos]
$creadListPrec :: ReadPrec [GlyphPos]
readPrec :: ReadPrec GlyphPos
$creadPrec :: ReadPrec GlyphPos
readList :: ReadS [GlyphPos]
$creadList :: ReadS [GlyphPos]
readsPrec :: Int -> ReadS GlyphPos
$creadsPrec :: Int -> ReadS GlyphPos
Read, GlyphPos -> GlyphPos -> Bool
(GlyphPos -> GlyphPos -> Bool)
-> (GlyphPos -> GlyphPos -> Bool) -> Eq GlyphPos
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GlyphPos -> GlyphPos -> Bool
$c/= :: GlyphPos -> GlyphPos -> Bool
== :: GlyphPos -> GlyphPos -> Bool
$c== :: GlyphPos -> GlyphPos -> Bool
Eq, (forall x. GlyphPos -> Rep GlyphPos x)
-> (forall x. Rep GlyphPos x -> GlyphPos) -> Generic GlyphPos
forall x. Rep GlyphPos x -> GlyphPos
forall x. GlyphPos -> Rep GlyphPos x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GlyphPos x -> GlyphPos
$cfrom :: forall x. GlyphPos -> Rep GlyphPos x
Generic)
instance Storable GlyphPos where
    sizeOf :: GlyphPos -> Int
sizeOf GlyphPos
_ = Int32 -> Int
forall a. Storable a => a -> Int
sizeOf (Int32
forall a. HasCallStack => a
undefined :: Int32) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
5
    alignment :: GlyphPos -> Int
alignment GlyphPos
_ = Int32 -> Int
forall a. Storable a => a -> Int
alignment (Int32
forall a. HasCallStack => a
undefined :: Int32)
    peek :: Ptr GlyphPos -> IO GlyphPos
peek Ptr GlyphPos
ptr = let ptr' :: Ptr b
ptr' = Ptr GlyphPos -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr Ptr GlyphPos
ptr in do
        Int32
x_advance' <- Ptr Int32
forall a. Ptr a
ptr' Ptr Int32 -> Int -> IO Int32
forall a. Storable a => Ptr a -> Int -> IO a
`peekElemOff` Int
0
        Int32
y_advance' <- Ptr Int32
forall a. Ptr a
ptr' Ptr Int32 -> Int -> IO Int32
forall a. Storable a => Ptr a -> Int -> IO a
`peekElemOff` Int
1
        Int32
x_offset' <- Ptr Int32
forall a. Ptr a
ptr' Ptr Int32 -> Int -> IO Int32
forall a. Storable a => Ptr a -> Int -> IO a
`peekElemOff` Int
2
        Int32
y_offset' <- Ptr Int32
forall a. Ptr a
ptr' Ptr Int32 -> Int -> IO Int32
forall a. Storable a => Ptr a -> Int -> IO a
`peekElemOff` Int
3
        GlyphPos -> IO GlyphPos
forall (m :: * -> *) a. Monad m => a -> m a
return (GlyphPos -> IO GlyphPos) -> GlyphPos -> IO GlyphPos
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32 -> Int32 -> Int32 -> GlyphPos
GlyphPos Int32
x_advance' Int32
y_advance' Int32
x_offset' Int32
y_offset'
    poke :: Ptr GlyphPos -> GlyphPos -> IO ()
poke Ptr GlyphPos
ptr (GlyphPos Int32
x_advance' Int32
y_advance' Int32
x_offset' Int32
y_offset') = do
        let ptr' :: Ptr Int32
            ptr' :: Ptr Int32
ptr' = Ptr GlyphPos -> Ptr Int32
forall a b. Ptr a -> Ptr b
castPtr Ptr GlyphPos
ptr
        Ptr Int32 -> Int -> Int32 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Int32
ptr' Int
0 Int32
x_advance'
        Ptr Int32 -> Int -> Int32 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Int32
ptr' Int
1 Int32
y_advance'
        Ptr Int32 -> Int -> Int32 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Int32
ptr' Int
2 Int32
x_offset'
        Ptr Int32 -> Int -> Int32 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Int32
ptr' Int
3 Int32
y_offset'
        Ptr Int32 -> Int -> Int32 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Int32
ptr' Int
4 Int32
0 -- Zero private field.
-- | Decodes `Buffer'`'s glyph position array.
-- If buffer did not have positions before, they will be initialized to zeros.'
glyphsPos :: Buffer' -> IO [GlyphPos]
glyphsPos Buffer'
buf' = do
    Ptr GlyphPos
arr <- IO (Ptr GlyphPos) -> IO (Ptr GlyphPos)
forall a. IO (Ptr a) -> IO (Ptr a)
throwNull (IO (Ptr GlyphPos) -> IO (Ptr GlyphPos))
-> IO (Ptr GlyphPos) -> IO (Ptr GlyphPos)
forall a b. (a -> b) -> a -> b
$ Buffer' -> Ptr Word -> IO (Ptr GlyphPos)
hb_buffer_get_glyph_positions Buffer'
buf' Ptr Word
forall a. Ptr a
nullPtr
    Word
length <- Buffer' -> IO Word
hb_buffer_get_length Buffer'
buf'
    if Word
length Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
0 Bool -> Bool -> Bool
|| Ptr GlyphPos
arr Ptr GlyphPos -> Ptr GlyphPos -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr GlyphPos
forall a. Ptr a
nullPtr
    then [GlyphPos] -> IO [GlyphPos]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else [Int] -> (Int -> IO GlyphPos) -> IO [GlyphPos]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0..Word -> Int
forall a. Enum a => a -> Int
fromEnum Word
length Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ((Int -> IO GlyphPos) -> IO [GlyphPos])
-> (Int -> IO GlyphPos) -> IO [GlyphPos]
forall a b. (a -> b) -> a -> b
$ Ptr GlyphPos -> Int -> IO GlyphPos
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr GlyphPos
arr
foreign import ccall "hb_buffer_get_glyph_positions" hb_buffer_get_glyph_positions
    :: Buffer' -> Ptr Word -> IO (Ptr GlyphPos)
-- NOTE: The array returned from FFI is valid as long as the buffer is.

-- | Decodes a `Buffer'` back to corresponding pure-functional `Buffer`.
thawBuffer :: Buffer' -> IO Buffer
thawBuffer :: Buffer' -> IO Buffer
thawBuffer Buffer'
buf' = do
    [GlyphInfo]
glyphInfos' <- Buffer' -> IO [GlyphInfo]
glyphInfos Buffer'
buf'
    Int
contentType' <- Buffer' -> IO Int
hb_buffer_get_content_type Buffer'
buf'
    Int
direction' <- Buffer' -> IO Int
hb_buffer_get_direction Buffer'
buf'
    Word32
script' <- Buffer' -> IO Word32
hb_buffer_get_script Buffer'
buf'
    CString
language'' <- Buffer' -> IO CString
hb_buffer_get_language Buffer'
buf'
    String
language' <- CString -> IO String
peekCString CString
language''
    Int
flags' <- Buffer' -> IO Int
hb_buffer_get_flags Buffer'
buf'
    Int
clusterLevel' <- Buffer' -> IO Int
hb_buffer_get_cluster_level Buffer'
buf'
    Word32
invisibleGlyph' <- Buffer' -> IO Word32
hb_buffer_get_invisible_glyph Buffer'
buf'
    Word32
replacementCodepoint' <- Buffer' -> IO Word32
hb_buffer_get_replacement_codepoint Buffer'
buf'
    Buffer -> IO Buffer
forall (m :: * -> *) a. Monad m => a -> m a
return Buffer
defaultBuffer {
        text :: Text
text = String -> Text
Lazy.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (GlyphInfo -> Char) -> [GlyphInfo] -> String
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (Word32 -> Char
w2c (Word32 -> Char) -> (GlyphInfo -> Word32) -> GlyphInfo -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlyphInfo -> Word32
codepoint) [GlyphInfo]
glyphInfos',
        contentType :: Maybe ContentType
contentType = case Int
contentType' of
            Int
1 -> ContentType -> Maybe ContentType
forall a. a -> Maybe a
Just ContentType
ContentTypeUnicode
            Int
2 -> ContentType -> Maybe ContentType
forall a. a -> Maybe a
Just ContentType
ContentTypeGlyphs
            Int
_ -> Maybe ContentType
forall a. Maybe a
Nothing,
        direction :: Maybe Direction
direction = Int -> Maybe Direction
forall {a}. (Eq a, Num a) => a -> Maybe Direction
int2dir Int
direction',
        script :: Maybe String
script = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Word32 -> String
tag_to_string Word32
script',
        language :: Maybe String
language = String -> Maybe String
forall a. a -> Maybe a
Just String
language',
        beginsText :: Bool
beginsText = Int -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Int
flags' Int
0, endsText :: Bool
endsText = Int -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Int
flags' Int
1,
        preserveDefaultIgnorables :: Bool
preserveDefaultIgnorables = Int -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Int
flags' Int
2,
        removeDefaultIgnorables :: Bool
removeDefaultIgnorables = Int -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Int
flags' Int
3,
        don'tInsertDottedCircle :: Bool
don'tInsertDottedCircle = Int -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Int
flags' Int
4,
        clusterLevel :: ClusterLevel
clusterLevel = case Int
clusterLevel' of
            Int
1 -> ClusterLevel
ClusterMonotoneChars
            Int
2 -> ClusterLevel
ClusterChars
            Int
_ -> ClusterLevel
ClusterMonotoneGraphemes,
        invisibleGlyph :: Char
invisibleGlyph = Word32 -> Char
w2c Word32
invisibleGlyph',
        replacementCodepoint :: Char
replacementCodepoint = Word32 -> Char
w2c Word32
replacementCodepoint'
    }
foreign import ccall "hb_buffer_get_content_type" hb_buffer_get_content_type
    :: Buffer' -> IO Int
foreign import ccall "hb_buffer_get_direction" hb_buffer_get_direction :: Buffer' -> IO Int
foreign import ccall "hb_buffer_get_script" hb_buffer_get_script :: Buffer' -> IO Word32
foreign import ccall "hb_buffer_get_language" hb_buffer_get_language :: Buffer' -> IO CString
foreign import ccall "hb_buffer_get_flags" hb_buffer_get_flags :: Buffer' -> IO Int
foreign import ccall "hb_buffer_get_cluster_level" hb_buffer_get_cluster_level
    :: Buffer' -> IO Int
foreign import ccall "hb_buffer_get_invisible_glyph" hb_buffer_get_invisible_glyph
    :: Buffer' -> IO Word32
foreign import ccall "hb_buffer_get_replacement_codepoint" hb_buffer_get_replacement_codepoint
    :: Buffer' -> IO Word32