{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
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(..))
data GlyphSize = CharSize Float Float Int Int
| PixelSize Int Int
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)
data SampleText = SampleText {
SampleText -> [Feature]
sampleFeatures :: [HB.Feature],
SampleText -> Text
sampleText :: Text,
SampleText -> Int
tabwidth :: Int,
SampleText -> FontOptions
fontOptions :: FontOptions,
SampleText -> Float
minLineHeight :: Float
}
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
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
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
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
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)
}
}
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
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
varItalic :: String
varItalic = String
"ital"
varOptSize :: String
varOptSize = String
"opsz"
varSlant :: String
varSlant = String
"slnt"
varWidth :: String
varWidth = String
"wdth"
varWeight :: String
varWeight = String
"wght"
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
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
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
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
}