{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE OverloadedStrings          #-}
-- |
-- Module:     Typograffiti.Monad
-- Copyright:  (c) 2018 Schell Scivally
-- License:    MIT
-- Maintainer: Schell Scivally <schell@takt.com>
--             & Adrian Cochrane <alcinnz@argonaut-constellation.org>
--
-- Text rendering abstraction, hiding the details of
-- the Atlas, Cache, and the Harfbuzz library.
module Typograffiti.Text where


import           Control.Monad.Except   (MonadError (..), runExceptT)
import           Control.Monad.Fail     (MonadFail (..))
import           Control.Monad.IO.Class (MonadIO (..))
import           Control.Monad          (foldM, forM, unless)
import qualified Data.IntSet            as IS
import           Linear                 (V2 (..))
import qualified Data.ByteString        as B
import           Data.Text.Glyphize     (defaultBuffer, shape, GlyphInfo (..),
                                        parseFeature, parseVariation, Variation (..),
                                        FontOptions (..), defaultFontOptions)
import qualified Data.Text.Glyphize     as HB
import           FreeType.Core.Base
import           FreeType.Core.Types    (FT_Fixed, FT_UShort)
import           FreeType.Format.Multiple (ft_Set_Var_Design_Coordinates)
import           Data.Text.Lazy         (Text, pack)
import qualified Data.Text.Lazy         as Txt
import           Data.Word              (Word32)
import           Foreign.Storable       (peek)

import           Typograffiti.Atlas
import           Typograffiti.Cache
import           Typograffiti.Rich      (RichText(..))

-- | How large the text should be rendered.
data GlyphSize = CharSize Float Float Int Int
                -- ^ Size in Pts at given DPI.
               | PixelSize Int Int
               -- ^ Size in device pixels.
               deriving (Int -> GlyphSize -> ShowS
[GlyphSize] -> ShowS
GlyphSize -> String
(Int -> GlyphSize -> ShowS)
-> (GlyphSize -> String)
-> ([GlyphSize] -> ShowS)
-> Show GlyphSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GlyphSize] -> ShowS
$cshowList :: [GlyphSize] -> ShowS
show :: GlyphSize -> String
$cshow :: GlyphSize -> String
showsPrec :: Int -> GlyphSize -> ShowS
$cshowsPrec :: Int -> GlyphSize -> ShowS
Show, GlyphSize -> GlyphSize -> Bool
(GlyphSize -> GlyphSize -> Bool)
-> (GlyphSize -> GlyphSize -> Bool) -> Eq GlyphSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GlyphSize -> GlyphSize -> Bool
$c/= :: GlyphSize -> GlyphSize -> Bool
== :: GlyphSize -> GlyphSize -> Bool
$c== :: GlyphSize -> GlyphSize -> Bool
Eq, Eq GlyphSize
Eq GlyphSize
-> (GlyphSize -> GlyphSize -> Ordering)
-> (GlyphSize -> GlyphSize -> Bool)
-> (GlyphSize -> GlyphSize -> Bool)
-> (GlyphSize -> GlyphSize -> Bool)
-> (GlyphSize -> GlyphSize -> Bool)
-> (GlyphSize -> GlyphSize -> GlyphSize)
-> (GlyphSize -> GlyphSize -> GlyphSize)
-> Ord GlyphSize
GlyphSize -> GlyphSize -> Bool
GlyphSize -> GlyphSize -> Ordering
GlyphSize -> GlyphSize -> GlyphSize
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 :: GlyphSize -> GlyphSize -> GlyphSize
$cmin :: GlyphSize -> GlyphSize -> GlyphSize
max :: GlyphSize -> GlyphSize -> GlyphSize
$cmax :: GlyphSize -> GlyphSize -> GlyphSize
>= :: GlyphSize -> GlyphSize -> Bool
$c>= :: GlyphSize -> GlyphSize -> Bool
> :: GlyphSize -> GlyphSize -> Bool
$c> :: GlyphSize -> GlyphSize -> Bool
<= :: GlyphSize -> GlyphSize -> Bool
$c<= :: GlyphSize -> GlyphSize -> Bool
< :: GlyphSize -> GlyphSize -> Bool
$c< :: GlyphSize -> GlyphSize -> Bool
compare :: GlyphSize -> GlyphSize -> Ordering
$ccompare :: GlyphSize -> GlyphSize -> Ordering
Ord)

-- | Extra parameters for constructing a font atlas,
-- and determining which glyphs should be in it.
data SampleText = SampleText {
    SampleText -> [Feature]
sampleFeatures :: [HB.Feature],
    -- ^ Which OpenType Features you want available to be used in the rendered text.
    -- Defaults to none.
    SampleText -> Text
sampleText :: Text,
    -- ^ Indicates which characters & ligatures will be in the text to be rendered.
    -- Defaults to ASCII, no ligatures.
    SampleText -> Int
tabwidth :: Int,
    -- ^ How many spaces wide should a tab be rendered?
    -- Defaults to 4 spaces.
    SampleText -> FontOptions
fontOptions :: FontOptions,
    -- ^ Additional font options offered by Harfbuzz.
    SampleText -> Float
minLineHeight :: Float
    -- ^ Number of pixels tall each line should be at minimum.
    -- Defaults to 0 indicate to use the font's default lineheight.
}

-- | Constructs a `SampleText` with default values.
defaultSample :: SampleText
defaultSample :: SampleText
defaultSample = [Feature] -> Text -> Int -> FontOptions -> Float -> SampleText
SampleText [] (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
forall a. Enum a => Int -> a
toEnum [Int
32..Int
126]) Int
4 FontOptions
defaultFontOptions Float
0
-- | Appends an OpenType feature callers may use to the `Sample` ensuring its
-- glyphs are available. Call after setting `sampleText`.
addSampleFeature :: String -> Word32 -> SampleText -> SampleText
addSampleFeature :: String -> Word32 -> SampleText -> SampleText
addSampleFeature String
name Word32
value sample :: SampleText
sample@SampleText {Float
Int
[Feature]
Text
FontOptions
minLineHeight :: Float
fontOptions :: FontOptions
tabwidth :: Int
sampleText :: Text
sampleFeatures :: [Feature]
minLineHeight :: SampleText -> Float
fontOptions :: SampleText -> FontOptions
tabwidth :: SampleText -> Int
sampleText :: SampleText -> Text
sampleFeatures :: SampleText -> [Feature]
..} = SampleText
sample {
        sampleFeatures :: [Feature]
sampleFeatures =
            Word32 -> Word32 -> Word -> Word -> Feature
HB.Feature (String -> Word32
HB.tag_from_string String
name) Word32
value (Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
*Word
i) (Word
nWord -> Word -> Word
forall a. Num a => a -> a -> a
*Word -> Word
forall a. Enum a => a -> a
succ Word
i) Feature -> [Feature] -> [Feature]
forall a. a -> [a] -> [a]
: [Feature]
sampleFeatures
    }
  where
    n :: Word
n = Int -> Word
w (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a. Enum a => a -> Int
fromEnum (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Int64
Txt.length Text
sampleText
    i :: Word
i = Int -> Word
w (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ [Feature] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Feature]
sampleFeatures
    w :: Int -> Word
    w :: Int -> Word
w = Int -> Word
forall a. Enum a => Int -> a
toEnum
-- | Parse an OpenType feature into this font using syntax akin to
-- CSS font-feature-settings.
parseSampleFeature :: String -> SampleText -> SampleText
parseSampleFeature :: String -> SampleText -> SampleText
parseSampleFeature String
syntax SampleText
sample | Just Feature
feat <- String -> Maybe Feature
parseFeature String
syntax = SampleText
sample {
        sampleFeatures :: [Feature]
sampleFeatures = Feature
feat Feature -> [Feature] -> [Feature]
forall a. a -> [a] -> [a]
: SampleText -> [Feature]
sampleFeatures SampleText
sample
    }
  | Bool
otherwise = SampleText
sample
-- | Parse multiple OpenType features into this font.
parseSampleFeatures :: [String] -> SampleText -> SampleText
parseSampleFeatures :: [String] -> SampleText -> SampleText
parseSampleFeatures = (SampleText -> [String] -> SampleText)
-> [String] -> SampleText -> SampleText
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((SampleText -> [String] -> SampleText)
 -> [String] -> SampleText -> SampleText)
-> (SampleText -> [String] -> SampleText)
-> [String]
-> SampleText
-> SampleText
forall a b. (a -> b) -> a -> b
$ (SampleText -> String -> SampleText)
-> SampleText -> [String] -> SampleText
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((SampleText -> String -> SampleText)
 -> SampleText -> [String] -> SampleText)
-> (SampleText -> String -> SampleText)
-> SampleText
-> [String]
-> SampleText
forall a b. (a -> b) -> a -> b
$ (String -> SampleText -> SampleText)
-> SampleText -> String -> SampleText
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> SampleText -> SampleText
parseSampleFeature
-- | Alter which OpenType variant of this font will be rendered.
-- Please check your font which variants are supported.
addFontVariant :: String -> Float -> SampleText -> SampleText
addFontVariant :: String -> Float -> SampleText -> SampleText
addFontVariant String
name Float
val SampleText
sampleText = SampleText
sampleText {
    fontOptions :: FontOptions
fontOptions = (SampleText -> FontOptions
fontOptions SampleText
sampleText) {
        optionVariations :: [Variation]
optionVariations = Word32 -> Float -> Variation
Variation (String -> Word32
HB.tag_from_string String
name) Float
val Variation -> [Variation] -> [Variation]
forall a. a -> [a] -> [a]
:
            FontOptions -> [Variation]
optionVariations (SampleText -> FontOptions
fontOptions SampleText
sampleText)
    }
  }
-- | Parse a OpenType variant into the configured font using syntax akin to
-- CSS font-variant-settings.
parseFontVariant :: String -> SampleText -> SampleText
parseFontVariant :: String -> SampleText -> SampleText
parseFontVariant String
syntax SampleText
sample | Just Variation
var <- String -> Maybe Variation
parseVariation String
syntax = SampleText
sample {
        fontOptions :: FontOptions
fontOptions = (SampleText -> FontOptions
fontOptions SampleText
sample) {
            optionVariations :: [Variation]
optionVariations = Variation
var Variation -> [Variation] -> [Variation]
forall a. a -> [a] -> [a]
: FontOptions -> [Variation]
optionVariations (SampleText -> FontOptions
fontOptions SampleText
sample)
        }
    }
  | Bool
otherwise = SampleText
sample
-- | Parse multiple OpenType variants into this font.
parseFontVariants :: [String] -> SampleText -> SampleText
parseFontVariants :: [String] -> SampleText -> SampleText
parseFontVariants = (SampleText -> [String] -> SampleText)
-> [String] -> SampleText -> SampleText
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((SampleText -> [String] -> SampleText)
 -> [String] -> SampleText -> SampleText)
-> (SampleText -> [String] -> SampleText)
-> [String]
-> SampleText
-> SampleText
forall a b. (a -> b) -> a -> b
$ (SampleText -> String -> SampleText)
-> SampleText -> [String] -> SampleText
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((SampleText -> String -> SampleText)
 -> SampleText -> [String] -> SampleText)
-> (SampleText -> String -> SampleText)
-> SampleText
-> [String]
-> SampleText
forall a b. (a -> b) -> a -> b
$ (String -> SampleText -> SampleText)
-> SampleText -> String -> SampleText
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> SampleText -> SampleText
parseFontVariant

-- | Standard italic font variant. Please check if your font supports this.
varItalic :: String
varItalic = String
"ital"
-- | Standard optical size font variant. Please check if your font supports this.
varOptSize :: String
varOptSize = String
"opsz"
-- | Standard slant (oblique) font variant. Please check if your font supports this.
varSlant :: String
varSlant = String
"slnt"
-- | Standard width font variant. Please check if your font supports this.
varWidth :: String
varWidth = String
"wdth"
-- | Standard weight (boldness) font variant. Please check if your font supports this.
varWeight :: String
varWeight = String
"wght"

-- | Opens a font sized to the given value & prepare to render text in it.
-- There is no need to keep the given `FT_Library` live before rendering the text.
makeDrawText :: (MonadIO m, MonadFail m, MonadError TypograffitiError m,
    MonadIO n, MonadFail n, MonadError TypograffitiError n) =>
    FT_Library -> FilePath -> Int -> GlyphSize -> SampleText ->
    m (RichText -> n (AllocatedRendering [TextTransform]))
makeDrawText :: forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadFail m, MonadError TypograffitiError m, MonadIO n,
 MonadFail n, MonadError TypograffitiError n) =>
FT_Library
-> String
-> Int
-> GlyphSize
-> SampleText
-> m (RichText -> n (AllocatedRendering [TextTransform]))
makeDrawText FT_Library
lib String
filepath Int
index GlyphSize
fontsize SampleText {Float
Int
[Feature]
Text
FontOptions
minLineHeight :: Float
fontOptions :: FontOptions
tabwidth :: Int
sampleText :: Text
sampleFeatures :: [Feature]
minLineHeight :: SampleText -> Float
fontOptions :: SampleText -> FontOptions
tabwidth :: SampleText -> Int
sampleText :: SampleText -> Text
sampleFeatures :: SampleText -> [Feature]
..} = do
    FT_Face
font <- IO FT_Face -> m FT_Face
forall (m :: * -> *) a.
(MonadIO m, MonadError TypograffitiError m) =>
IO a -> m a
liftFreetype (IO FT_Face -> m FT_Face) -> IO FT_Face -> m FT_Face
forall a b. (a -> b) -> a -> b
$ FT_Library -> String -> Int64 -> IO FT_Face
ft_New_Face FT_Library
lib String
filepath (Int64 -> IO FT_Face) -> Int64 -> IO FT_Face
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a. Enum a => Int -> a
toEnum Int
index
    IO () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadError TypograffitiError m) =>
IO a -> m a
liftFreetype (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ case GlyphSize
fontsize of
        PixelSize Int
w Int
h -> FT_Face -> Word32 -> Word32 -> IO ()
ft_Set_Pixel_Sizes FT_Face
font (Int -> Word32
forall a. Enum a => Int -> a
toEnum (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> Int
x2 Int
w) (Int -> Word32
forall a. Enum a => Int -> a
toEnum (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> Int
x2 Int
h)
        CharSize Float
w Float
h Int
dpix Int
dpiy -> FT_Face -> Int64 -> Int64 -> Word32 -> Word32 -> IO ()
ft_Set_Char_Size FT_Face
font (Float -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int64) -> Float -> Int64
forall a b. (a -> b) -> a -> b
$ Float
26.6 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
w)
                                                    (Float -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int64) -> Float -> Int64
forall a b. (a -> b) -> a -> b
$ Float
26.6 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
h)
                                                    (Int -> Word32
forall a. Enum a => Int -> a
toEnum Int
dpix) (Int -> Word32
forall a. Enum a => Int -> a
toEnum Int
dpiy)

    FT_FaceRec
font_ <- IO FT_FaceRec -> m FT_FaceRec
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FT_FaceRec -> m FT_FaceRec) -> IO FT_FaceRec -> m FT_FaceRec
forall a b. (a -> b) -> a -> b
$ FT_Face -> IO FT_FaceRec
forall a. Storable a => Ptr a -> IO a
peek FT_Face
font
    FT_Size_Metrics
size <- FT_SizeRec -> FT_Size_Metrics
srMetrics (FT_SizeRec -> FT_Size_Metrics)
-> m FT_SizeRec -> m FT_Size_Metrics
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FT_SizeRec -> m FT_SizeRec
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr FT_SizeRec -> IO FT_SizeRec
forall a. Storable a => Ptr a -> IO a
peek (Ptr FT_SizeRec -> IO FT_SizeRec)
-> Ptr FT_SizeRec -> IO FT_SizeRec
forall a b. (a -> b) -> a -> b
$ FT_FaceRec -> Ptr FT_SizeRec
frSize FT_FaceRec
font_)
    let lineHeight :: Float
lineHeight = if Float
minLineHeight Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 then Int64 -> Float
fixed2float (Int64 -> Float) -> Int64 -> Float
forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> Int64
smHeight FT_Size_Metrics
size else Float
minLineHeight
    let upem :: Float
upem = FT_UShort -> Float
short2float (FT_UShort -> Float) -> FT_UShort -> Float
forall a b. (a -> b) -> a -> b
$ FT_FaceRec -> FT_UShort
frUnits_per_EM FT_FaceRec
font_
    let scale :: (Float, Float)
scale = (FT_UShort -> Float
short2float (FT_Size_Metrics -> FT_UShort
smX_ppem FT_Size_Metrics
size)Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
upemFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
2, FT_UShort -> Float
short2float (FT_Size_Metrics -> FT_UShort
smY_ppem FT_Size_Metrics
size)Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
upemFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
2)

    ByteString
bytes <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
filepath
    let fontOpts' :: FontOptions
fontOpts' = FontOptions
fontOptions {
            optionScale :: Maybe (Int, Int)
HB.optionScale = Maybe (Int, Int)
forall a. Maybe a
Nothing, optionPtEm :: Maybe Float
HB.optionPtEm = Maybe Float
forall a. Maybe a
Nothing, optionPPEm :: Maybe (Word, Word)
HB.optionPPEm = Maybe (Word, Word)
forall a. Maybe a
Nothing
      }
    let font' :: Font
font' = FontOptions -> Face -> Font
HB.createFontWithOptions FontOptions
fontOpts' (Face -> Font) -> Face -> Font
forall a b. (a -> b) -> a -> b
$ ByteString -> Word -> Face
HB.createFace ByteString
bytes (Word -> Face) -> Word -> Face
forall a b. (a -> b) -> a -> b
$ Int -> Word
forall a. Enum a => Int -> a
toEnum Int
index
    let glyphs :: [Word32]
glyphs = ((GlyphInfo, GlyphPos) -> Word32)
-> [(GlyphInfo, GlyphPos)] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map (GlyphInfo -> Word32
codepoint (GlyphInfo -> Word32)
-> ((GlyphInfo, GlyphPos) -> GlyphInfo)
-> (GlyphInfo, GlyphPos)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlyphInfo, GlyphPos) -> GlyphInfo
forall a b. (a, b) -> a
fst) ([(GlyphInfo, GlyphPos)] -> [Word32])
-> [(GlyphInfo, GlyphPos)] -> [Word32]
forall a b. (a -> b) -> a -> b
$
            Font -> Buffer -> [Feature] -> [(GlyphInfo, GlyphPos)]
shape Font
font' Buffer
defaultBuffer {
                text :: Text
HB.text = Int64 -> Text -> Text
Txt.replicate (Int -> Int64
forall a. Enum a => Int -> a
toEnum (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Feature] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Feature]
sampleFeatures) Text
sampleText
            } [Feature]
sampleFeatures
    let glyphs' :: [Word32]
glyphs' = (Int -> Word32) -> [Int] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Word32
forall a. Enum a => Int -> a
toEnum ([Int] -> [Word32]) -> [Int] -> [Word32]
forall a b. (a -> b) -> a -> b
$ IntSet -> [Int]
IS.toList (IntSet -> [Int]) -> IntSet -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> IntSet
IS.fromList ([Int] -> IntSet) -> [Int] -> IntSet
forall a b. (a -> b) -> a -> b
$ (Word32 -> Int) -> [Word32] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> Int
forall a. Enum a => a -> Int
fromEnum [Word32]
glyphs

    let designCoords :: [Int64]
designCoords = (Float -> Int64) -> [Float] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map Float -> Int64
float2fixed ([Float] -> [Int64]) -> [Float] -> [Int64]
forall a b. (a -> b) -> a -> b
$ Font -> [Float]
HB.fontVarCoordsDesign Font
font'
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Int64] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int64]
designCoords) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        IO () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadError TypograffitiError m) =>
IO a -> m a
liftFreetype (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FT_Face -> [Int64] -> IO ()
ft_Set_Var_Design_Coordinates FT_Face
font [Int64]
designCoords

    Atlas
atlas <- GlyphRetriever m -> [Word32] -> (Float, Float) -> m Atlas
forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadError TypograffitiError m) =>
GlyphRetriever m -> [Word32] -> (Float, Float) -> m Atlas
allocAtlas (FT_Face -> GlyphRetriever m
forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
FT_Face -> GlyphRetriever m
glyphRetriever FT_Face
font) [Word32]
glyphs' (Float, Float)
scale
    IO () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadError TypograffitiError m) =>
IO a -> m a
liftFreetype (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FT_Face -> IO ()
ft_Done_Face FT_Face
font

    Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
drawGlyphs <- m (Atlas
   -> [(GlyphInfo, GlyphPos)]
   -> n (AllocatedRendering [TextTransform]))
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadError TypograffitiError m, MonadIO n, MonadFail n,
 MonadError TypograffitiError n) =>
m (Atlas
   -> [(GlyphInfo, GlyphPos)]
   -> n (AllocatedRendering [TextTransform]))
makeDrawGlyphs
    (RichText -> n (AllocatedRendering [TextTransform]))
-> m (RichText -> n (AllocatedRendering [TextTransform]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((RichText -> n (AllocatedRendering [TextTransform]))
 -> m (RichText -> n (AllocatedRendering [TextTransform])))
-> (RichText -> n (AllocatedRendering [TextTransform]))
-> m (RichText -> n (AllocatedRendering [TextTransform]))
forall a b. (a -> b) -> a -> b
$ Atlas
-> (RichText -> n (AllocatedRendering [TextTransform]))
-> RichText
-> n (AllocatedRendering [TextTransform])
forall (m :: * -> *).
MonadIO m =>
Atlas -> TextRenderer m -> TextRenderer m
freeAtlasWrapper Atlas
atlas ((RichText -> n (AllocatedRendering [TextTransform]))
 -> RichText -> n (AllocatedRendering [TextTransform]))
-> (RichText -> n (AllocatedRendering [TextTransform]))
-> RichText
-> n (AllocatedRendering [TextTransform])
forall a b. (a -> b) -> a -> b
$ Int
-> Float
-> (RichText -> n (AllocatedRendering [TextTransform]))
-> RichText
-> n (AllocatedRendering [TextTransform])
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Int -> Float -> TextRenderer m -> TextRenderer m
drawLinesWrapper Int
tabwidth Float
lineHeight
        ((RichText -> n (AllocatedRendering [TextTransform]))
 -> RichText -> n (AllocatedRendering [TextTransform]))
-> (RichText -> n (AllocatedRendering [TextTransform]))
-> RichText
-> n (AllocatedRendering [TextTransform])
forall a b. (a -> b) -> a -> b
$ \RichText {[Feature]
Text
features :: RichText -> [Feature]
text :: RichText -> Text
features :: [Feature]
text :: Text
..} ->
            Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
drawGlyphs Atlas
atlas ([(GlyphInfo, GlyphPos)] -> n (AllocatedRendering [TextTransform]))
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
forall a b. (a -> b) -> a -> b
$ Font -> Buffer -> [Feature] -> [(GlyphInfo, GlyphPos)]
shape Font
font' Buffer
defaultBuffer { text :: Text
HB.text = Text
text } [Feature]
features
  where
    x2 :: Int -> Int
x2 = (Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
2)
    float2fixed :: Float -> FT_Fixed
    float2fixed :: Float -> Int64
float2fixed = Int -> Int64
forall a. Enum a => Int -> a
toEnum (Int -> Int64) -> (Float -> Int) -> Float -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Int
forall a. Enum a => a -> Int
fromEnum (Float -> Int) -> (Float -> Float) -> Float -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
bits16)
    fixed2float :: FT_Fixed -> Float
    fixed2float :: Int64 -> Float
fixed2float = (Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
bits16) (Float -> Float) -> (Int64 -> Float) -> Int64 -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Float
forall a. Enum a => Int -> a
toEnum (Int -> Float) -> (Int64 -> Int) -> Int64 -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a. Enum a => a -> Int
fromEnum
    bits16 :: Float
bits16 = Float
2Float -> Float -> Float
forall a. Floating a => a -> a -> a
**Float
16
    short2float :: FT_UShort -> Float
    short2float :: FT_UShort -> Float
short2float = Int -> Float
forall a. Enum a => Int -> a
toEnum (Int -> Float) -> (FT_UShort -> Int) -> FT_UShort -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FT_UShort -> Int
forall a. Enum a => a -> Int
fromEnum

-- | Variant of `makeDrawText` which initializes FreeType itself.
makeDrawText' :: String
-> Int
-> GlyphSize
-> SampleText
-> IO
     (Either
        TypograffitiError
        (RichText -> n (AllocatedRendering [TextTransform])))
makeDrawText' String
a Int
b GlyphSize
c SampleText
d =
    (FT_Library
 -> IO
      (Either
         TypograffitiError
         (RichText -> n (AllocatedRendering [TextTransform]))))
-> IO
     (Either
        TypograffitiError
        (RichText -> n (AllocatedRendering [TextTransform])))
forall a. (FT_Library -> IO a) -> IO a
ft_With_FreeType ((FT_Library
  -> IO
       (Either
          TypograffitiError
          (RichText -> n (AllocatedRendering [TextTransform]))))
 -> IO
      (Either
         TypograffitiError
         (RichText -> n (AllocatedRendering [TextTransform]))))
-> (FT_Library
    -> IO
         (Either
            TypograffitiError
            (RichText -> n (AllocatedRendering [TextTransform]))))
-> IO
     (Either
        TypograffitiError
        (RichText -> n (AllocatedRendering [TextTransform])))
forall a b. (a -> b) -> a -> b
$ \FT_Library
ft -> ExceptT
  TypograffitiError
  IO
  (RichText -> n (AllocatedRendering [TextTransform]))
-> IO
     (Either
        TypograffitiError
        (RichText -> n (AllocatedRendering [TextTransform])))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   TypograffitiError
   IO
   (RichText -> n (AllocatedRendering [TextTransform]))
 -> IO
      (Either
         TypograffitiError
         (RichText -> n (AllocatedRendering [TextTransform]))))
-> ExceptT
     TypograffitiError
     IO
     (RichText -> n (AllocatedRendering [TextTransform]))
-> IO
     (Either
        TypograffitiError
        (RichText -> n (AllocatedRendering [TextTransform])))
forall a b. (a -> b) -> a -> b
$ FT_Library
-> String
-> Int
-> GlyphSize
-> SampleText
-> ExceptT
     TypograffitiError
     IO
     (RichText -> n (AllocatedRendering [TextTransform]))
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadFail m, MonadError TypograffitiError m, MonadIO n,
 MonadFail n, MonadError TypograffitiError n) =>
FT_Library
-> String
-> Int
-> GlyphSize
-> SampleText
-> m (RichText -> n (AllocatedRendering [TextTransform]))
makeDrawText FT_Library
ft String
a Int
b GlyphSize
c SampleText
d

-- | Internal utility for rendering multiple lines of text & expanding tabs as configured.
type TextRenderer m = RichText -> m (AllocatedRendering [TextTransform])
drawLinesWrapper :: (MonadIO m, MonadFail m) => Int -> Float -> TextRenderer m -> TextRenderer m
drawLinesWrapper :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Int -> Float -> TextRenderer m -> TextRenderer m
drawLinesWrapper Int
indent Float
lineheight TextRenderer m
cb RichText {[Feature]
Text
features :: [Feature]
text :: Text
features :: RichText -> [Feature]
text :: RichText -> Text
..} = do
    let features' :: [[Feature]]
features' = Word -> [Feature] -> [Text] -> [[Feature]]
splitFeatures Word
0 [Feature]
features (Text -> [Text]
Txt.lines Text
text) [[Feature]] -> [[Feature]] -> [[Feature]]
forall a. [a] -> [a] -> [a]
++ [Feature] -> [[Feature]]
forall a. a -> [a]
repeat []
    let cb' :: (Text, [Feature]) -> m (AllocatedRendering [TextTransform])
cb' (Text
a, [Feature]
b) = TextRenderer m
cb TextRenderer m -> TextRenderer m
forall a b. (a -> b) -> a -> b
$ Text -> [Feature] -> RichText
RichText Text
a [Feature]
b
    [AllocatedRendering [TextTransform]]
renderers <- ((Text, [Feature]) -> m (AllocatedRendering [TextTransform]))
-> [(Text, [Feature])] -> m [AllocatedRendering [TextTransform]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text, [Feature]) -> m (AllocatedRendering [TextTransform])
cb' ([(Text, [Feature])] -> m [AllocatedRendering [TextTransform]])
-> [(Text, [Feature])] -> m [AllocatedRendering [TextTransform]]
forall a b. (a -> b) -> a -> b
$ ([Text] -> [[Feature]] -> [(Text, [Feature])])
-> [[Feature]] -> [Text] -> [(Text, [Feature])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Text] -> [[Feature]] -> [(Text, [Feature])]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Feature]]
features' ([Text] -> [(Text, [Feature])]) -> [Text] -> [(Text, [Feature])]
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
processLine ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Txt.lines Text
text
    let drawLine :: [TextTransform]
-> V2 Int
-> Float
-> AllocatedRendering [TextTransform]
-> IO Float
drawLine [TextTransform]
ts V2 Int
wsz Float
y AllocatedRendering [TextTransform]
renderer = do
            AllocatedRendering [TextTransform]
-> [TextTransform] -> V2 Int -> IO ()
forall t. AllocatedRendering t -> t -> V2 Int -> IO ()
arDraw AllocatedRendering [TextTransform]
renderer (Float -> Float -> TextTransform
move Float
0 Float
yTextTransform -> [TextTransform] -> [TextTransform]
forall a. a -> [a] -> [a]
:[TextTransform]
ts) V2 Int
wsz
            let V2 Int
_ Int
height = AllocatedRendering [TextTransform] -> V2 Int
forall t. AllocatedRendering t -> V2 Int
arSize AllocatedRendering [TextTransform]
renderer
            Float -> IO Float
forall (m :: * -> *) a. Monad m => a -> m a
return (Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
lineheight (Int -> Float
forall a. Enum a => Int -> a
toEnum Int
height))
    let draw :: [TextTransform] -> V2 Int -> IO ()
draw [TextTransform]
ts V2 Int
wsz = do
            (Float -> AllocatedRendering [TextTransform] -> IO Float)
-> Float -> [AllocatedRendering [TextTransform]] -> IO Float
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([TextTransform]
-> V2 Int
-> Float
-> AllocatedRendering [TextTransform]
-> IO Float
drawLine [TextTransform]
ts V2 Int
wsz) Float
0 [AllocatedRendering [TextTransform]]
renderers
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    let sizes :: [V2 Int]
sizes = (AllocatedRendering [TextTransform] -> V2 Int)
-> [AllocatedRendering [TextTransform]] -> [V2 Int]
forall a b. (a -> b) -> [a] -> [b]
map AllocatedRendering [TextTransform] -> V2 Int
forall t. AllocatedRendering t -> V2 Int
arSize [AllocatedRendering [TextTransform]]
renderers
    let size :: V2 Int
size = Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int
x | V2 Int
x Int
_ <- [V2 Int]
sizes]) ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
y | V2 Int
_ Int
y <- [V2 Int]
sizes])
    let release :: IO ()
release = do
            [AllocatedRendering [TextTransform]]
-> (AllocatedRendering [TextTransform] -> IO ()) -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AllocatedRendering [TextTransform]]
renderers AllocatedRendering [TextTransform] -> IO ()
forall t. AllocatedRendering t -> IO ()
arRelease
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    AllocatedRendering [TextTransform]
-> m (AllocatedRendering [TextTransform])
forall (m :: * -> *) a. Monad m => a -> m a
return AllocatedRendering :: forall t.
(t -> V2 Int -> IO ()) -> IO () -> V2 Int -> AllocatedRendering t
AllocatedRendering {
            arDraw :: [TextTransform] -> V2 Int -> IO ()
arDraw = [TextTransform] -> V2 Int -> IO ()
draw,
            arRelease :: IO ()
arRelease = IO ()
release,
            arSize :: V2 Int
arSize = V2 Int
size
          }
  where
    splitFeatures :: Word -> [HB.Feature] -> [Text] -> [[HB.Feature]]
    splitFeatures :: Word -> [Feature] -> [Text] -> [[Feature]]
splitFeatures Word
_ [] [Text]
_ = []
    splitFeatures Word
_ [Feature]
_ [] = []
    splitFeatures Word
offset [Feature]
features' (Text
line:[Text]
lines') = let n :: Int
n = Int64 -> Int
forall a. Enum a => a -> Int
fromEnum (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Int64
Txt.length Text
line
        in [Feature
feat {
                featStart :: Word
HB.featStart = Word -> Word -> Word
forall a. Ord a => a -> a -> a
max Word
0 (Word
start Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
offset),
                featEnd :: Word
HB.featEnd = Word -> Word -> Word
forall a. Ord a => a -> a -> a
min (Int -> Word
forall a. Enum a => Int -> a
toEnum Int
n) (Word
end Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
offset)
              }
            | feat :: Feature
feat@HB.Feature {featStart :: Feature -> Word
HB.featStart = Word
start, featEnd :: Feature -> Word
HB.featEnd = Word
end} <- [Feature]
features',
            Word -> Int
forall a. Enum a => a -> Int
fromEnum Word
end Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word -> Int
forall a. Enum a => a -> Int
fromEnum Word
offset Bool -> Bool -> Bool
&& Word
end Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
>= Word
offset] [Feature] -> [[Feature]] -> [[Feature]]
forall a. a -> [a] -> [a]
:
            Word -> [Feature] -> [Text] -> [[Feature]]
splitFeatures (Word
offset Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Int -> Word
forall a. Enum a => Int -> a
toEnum Int
n) [Feature]
features' [Text]
lines'

    processLine :: Text -> Text
    processLine :: Text -> Text
processLine Text
cs = Int64 -> Text -> Text
expandTabs Int64
0 Text
cs
    -- monospace tabshaping, good enough outside full line-layout.
    expandTabs :: Int64 -> Text -> Text
expandTabs Int64
n Text
cs = case (Char -> Bool) -> Text -> (Text, Text)
Txt.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t') Text
cs of
        (Text
tail, Text
"") -> Text
tail
        (Text
pre, Text
cs') ->
            let spaces :: Int
spaces = Int
indent Int -> Int -> Int
forall a. Num a => a -> a -> a
- ((Int64 -> Int
forall a. Enum a => a -> Int
fromEnum (Text -> Int64
Txt.length Text
pre) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int64 -> Int
forall a. Enum a => a -> Int
fromEnum Int64
n) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
indent)
            in [Text] -> Text
Txt.concat [Text
pre, Int64 -> Text -> Text
Txt.replicate (Int -> Int64
forall a. Enum a => Int -> a
toEnum Int
spaces) Text
" ",
                Int64 -> Text -> Text
expandTabs (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Text -> Int64
Txt.length Text
pre Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int -> Int64
forall a. Enum a => Int -> a
toEnum Int
spaces) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text
Text -> Text
Txt.tail Text
cs']

freeAtlasWrapper :: MonadIO m => Atlas -> TextRenderer m -> TextRenderer m
freeAtlasWrapper :: forall (m :: * -> *).
MonadIO m =>
Atlas -> TextRenderer m -> TextRenderer m
freeAtlasWrapper Atlas
atlas TextRenderer m
cb RichText
text = do
    AllocatedRendering [TextTransform]
ret <- TextRenderer m
cb RichText
text
    AllocatedRendering [TextTransform]
-> m (AllocatedRendering [TextTransform])
forall (m :: * -> *) a. Monad m => a -> m a
return AllocatedRendering [TextTransform]
ret {
        arRelease :: IO ()
arRelease = do
            AllocatedRendering [TextTransform] -> IO ()
forall t. AllocatedRendering t -> IO ()
arRelease AllocatedRendering [TextTransform]
ret
            Atlas -> IO ()
forall (m :: * -> *). MonadIO m => Atlas -> m ()
freeAtlas Atlas
atlas
    }