{-|
Module      : Monomer.Graphics.Text
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Helper functions for calculating text size.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}

module Monomer.Graphics.Text (
  calcTextSize,
  calcTextSize_,
  fitTextToSize,
  fitTextToWidth,
  alignTextLines,
  moveTextLines,
  getTextLinesSize,
  getGlyphsMin,
  getGlyphsMax
) where

import Control.Lens ((&), (^.), (^?), (+~), ix, non)
import Data.Default
import Data.List (foldl')
import Data.Maybe
import Data.Sequence (Seq(..), (<|), (|>))
import Data.Text (Text)

import qualified Data.Sequence as Seq
import qualified Data.Text as T

import Monomer.Common
import Monomer.Core.StyleTypes
import Monomer.Core.StyleUtil
import Monomer.Graphics.Types
import Monomer.Helper

import qualified Monomer.Common.Lens as L
import qualified Monomer.Graphics.Lens as L

type GlyphGroup = Seq GlyphPos

-- | Returns the size a given text an style will take.
calcTextSize
  :: FontManager   -- ^ The font manager.
  -> StyleState    -- ^ The style.
  -> Text          -- ^ The text to calculate.
  -> Size          -- ^ The calculated size.
calcTextSize :: FontManager -> StyleState -> Text -> Size
calcTextSize FontManager
fontMgr StyleState
style !Text
text = Size
size where
  size :: Size
size = FontManager
-> StyleState
-> TextMode
-> TextTrim
-> Maybe Double
-> Maybe Int
-> Text
-> Size
calcTextSize_ FontManager
fontMgr StyleState
style TextMode
SingleLine TextTrim
KeepSpaces forall a. Maybe a
Nothing forall a. Maybe a
Nothing Text
text

-- | Returns the size a given text an style will take.
calcTextSize_
  :: FontManager   -- ^ The font manager.
  -> StyleState    -- ^ The style.
  -> TextMode      -- ^ Single or multiline.
  -> TextTrim      -- ^ Whether to trim or keep spaces.
  -> Maybe Double  -- ^ Optional max width (needed for multiline).
  -> Maybe Int     -- ^ Optional max lines.
  -> Text          -- ^ The text to calculate.
  -> Size          -- ^ The calculated size.
calcTextSize_ :: FontManager
-> StyleState
-> TextMode
-> TextTrim
-> Maybe Double
-> Maybe Int
-> Text
-> Size
calcTextSize_ FontManager
fontMgr StyleState
style TextMode
mode TextTrim
trim Maybe Double
mwidth Maybe Int
mlines Text
text = Size
newSize where
  font :: Font
font = StyleState -> Font
styleFont StyleState
style
  fontSize :: FontSize
fontSize = StyleState -> FontSize
styleFontSize StyleState
style
  !metrics :: TextMetrics
metrics = FontManager -> Font -> FontSize -> TextMetrics
computeTextMetrics FontManager
fontMgr Font
font FontSize
fontSize
  width :: Double
width = forall a. a -> Maybe a -> a
fromMaybe forall a. RealFloat a => a
maxNumericValue Maybe Double
mwidth

  textLinesW :: Seq TextLine
textLinesW = FontManager
-> StyleState -> Double -> TextTrim -> Text -> Seq TextLine
fitTextToWidth FontManager
fontMgr StyleState
style Double
width TextTrim
trim Text
text
  textLines :: Seq TextLine
textLines
    | TextMode
mode forall a. Eq a => a -> a -> Bool
== TextMode
SingleLine = forall a. Int -> Seq a -> Seq a
Seq.take Int
1 Seq TextLine
textLinesW
    | forall a. Maybe a -> Bool
isJust Maybe Int
mlines = forall a. Int -> Seq a -> Seq a
Seq.take (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
mlines) Seq TextLine
textLinesW
    | Bool
otherwise = Seq TextLine
textLinesW

  newSize :: Size
newSize
    | Bool -> Bool
not (forall a. Seq a -> Bool
Seq.null Seq TextLine
textLines) = Seq TextLine -> Size
getTextLinesSize Seq TextLine
textLines
    | Bool
otherwise = Double -> Double -> Size
Size Double
0 (TextMetrics -> Double
_txmLineH TextMetrics
metrics)

{-|
Fits the given text to a determined size, splitting on multiple lines as needed.
Since the function returns glyphs that may be partially visible, the text can
overflow vertically or horizontally and a scissor is needed. The rectangles are
returned with zero offset (i.e., x = 0 and first line y = 0), and a translation
transform is needed when rendering.
-}
fitTextToSize
  :: FontManager   -- ^ The font manager.
  -> StyleState    -- ^ The style.
  -> TextOverflow  -- ^ Whether to clip or use ellipsis.
  -> TextMode      -- ^ Single or multiline.
  -> TextTrim      -- ^ Whether to trim or keep spaces.
  -> Maybe Int     -- ^ Optional max lines.
  -> Size          -- ^ The bounding size.
  -> Text          -- ^ The text to fit.
  -> Seq TextLine  -- ^ The fitted text lines.
fitTextToSize :: FontManager
-> StyleState
-> TextOverflow
-> TextMode
-> TextTrim
-> Maybe Int
-> Size
-> Text
-> Seq TextLine
fitTextToSize FontManager
fontMgr StyleState
style TextOverflow
ovf TextMode
mode TextTrim
trim Maybe Int
mlines !Size
size !Text
text = Seq TextLine
newLines where
  Size Double
cw Double
ch = Size
size
  font :: Font
font = StyleState -> Font
styleFont StyleState
style
  fontSize :: FontSize
fontSize = StyleState -> FontSize
styleFontSize StyleState
style
  textMetrics :: TextMetrics
textMetrics = FontManager -> Font -> FontSize -> TextMetrics
computeTextMetrics FontManager
fontMgr Font
font FontSize
fontSize

  fitW :: Double
fitW
    | TextMode
mode forall a. Eq a => a -> a -> Bool
== TextMode
MultiLine = Double
cw
    | Bool
otherwise = forall a. RealFloat a => a
maxNumericValue
  maxH :: Double
maxH = case Maybe Int
mlines of
    Just Int
maxLines -> forall a. Ord a => a -> a -> a
min Double
ch (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxLines forall a. Num a => a -> a -> a
* TextMetrics
textMetrics forall s a. s -> Getting a s a -> a
^. forall s a. HasLineH s a => Lens' s a
L.lineH)
    Maybe Int
_ -> Double
ch

  textLinesW :: Seq TextLine
textLinesW = FontManager
-> StyleState -> Double -> TextTrim -> Text -> Seq TextLine
fitTextToWidth FontManager
fontMgr StyleState
style Double
fitW TextTrim
trim Text
text
  firstLine :: Seq TextLine
firstLine = forall a. Int -> Seq a -> Seq a
Seq.take Int
1 Seq TextLine
textLinesW
  isMultiline :: Bool
isMultiline = TextMode
mode forall a. Eq a => a -> a -> Bool
== TextMode
MultiLine
  ellipsisReq :: Bool
ellipsisReq = TextOverflow
ovf forall a. Eq a => a -> a -> Bool
== TextOverflow
Ellipsis Bool -> Bool -> Bool
&& Seq TextLine -> Size
getTextLinesSize Seq TextLine
firstLine forall s a. s -> Getting a s a -> a
^. forall s a. HasW s a => Lens' s a
L.w forall a. Ord a => a -> a -> Bool
> Double
cw

  newLines :: Seq TextLine
newLines
    | Bool
isMultiline = FontManager
-> StyleState
-> TextOverflow
-> Double
-> Double
-> Seq TextLine
-> Seq TextLine
fitLinesToH FontManager
fontMgr StyleState
style TextOverflow
ovf Double
cw Double
maxH Seq TextLine
textLinesW
    | Bool
ellipsisReq = FontManager -> StyleState -> Double -> TextLine -> TextLine
addEllipsisToTextLine FontManager
fontMgr StyleState
style Double
cw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq TextLine
firstLine
    | Bool
otherwise = FontManager
-> StyleState -> TextTrim -> Double -> TextLine -> TextLine
clipTextLine FontManager
fontMgr StyleState
style TextTrim
trim Double
cw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq TextLine
firstLine

-- | Fits a single line of text to the given width, potencially spliting into
--   several lines.
fitTextToWidth
  :: FontManager   -- ^ The fontManager.
  -> StyleState    -- ^ The style.
  -> Double        -- ^ The maximum width.
  -> TextTrim      -- ^ Whether to trim or keep spaces.
  -> Text          -- ^ The text to calculate.
  -> Seq TextLine  -- ^ The fitted text lines.
fitTextToWidth :: FontManager
-> StyleState -> Double -> TextTrim -> Text -> Seq TextLine
fitTextToWidth FontManager
fontMgr StyleState
style Double
width TextTrim
trim Text
text = Seq TextLine
resultLines where
  font :: Font
font = StyleState -> Font
styleFont StyleState
style
  fSize :: FontSize
fSize = StyleState -> FontSize
styleFontSize StyleState
style
  fSpcH :: FontSpace
fSpcH = StyleState -> FontSpace
styleFontSpaceH StyleState
style
  fSpcV :: FontSpace
fSpcV = StyleState -> FontSpace
styleFontSpaceV StyleState
style
  break :: LineBreak
break = StyleState -> LineBreak
styleTextLineBreak StyleState
style
  lineH :: Double
lineH = TextMetrics -> Double
_txmLineH TextMetrics
metrics

  !metrics :: TextMetrics
metrics = FontManager -> Font -> FontSize -> TextMetrics
computeTextMetrics FontManager
fontMgr Font
font FontSize
fSize
  fitToWidth :: Double -> Double -> TextTrim -> Text -> Seq TextLine
fitToWidth = FontManager
-> Font
-> FontSize
-> FontSpace
-> FontSpace
-> TextMetrics
-> LineBreak
-> Double
-> Double
-> TextTrim
-> Text
-> Seq TextLine
fitLineToW FontManager
fontMgr Font
font FontSize
fSize FontSpace
fSpcH FontSpace
fSpcV TextMetrics
metrics LineBreak
break

  helper :: (Seq TextLine, Double) -> Text -> (Seq TextLine, Double)
helper (Seq TextLine, Double)
acc Text
line = (Seq TextLine
cLines forall a. Semigroup a => a -> a -> a
<> Seq TextLine
newLines, Double
newTop) where
    (Seq TextLine
cLines, Double
cTop) = (Seq TextLine, Double)
acc
    newLines :: Seq TextLine
newLines = Double -> Double -> TextTrim -> Text -> Seq TextLine
fitToWidth Double
cTop Double
width TextTrim
trim Text
line
    vspc :: Double
vspc = FontSpace -> Double
unFontSpace FontSpace
fSpcV
    newTop :: Double
newTop = Double
cTop forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Seq a -> Int
Seq.length Seq TextLine
newLines) forall a. Num a => a -> a -> a
* (Double
lineH forall a. Num a => a -> a -> a
+ Double
vspc)

  (Seq TextLine
resultLines, Double
_) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Seq TextLine, Double) -> Text -> (Seq TextLine, Double)
helper (forall a. Seq a
Empty, Double
0) (Text -> [Text]
T.lines Text
text)

-- | Aligns a Seq of TextLines to the given rect.
alignTextLines
  :: StyleState    -- ^ The style.
  -> Rect          -- ^ The bounding rect. Text may overflow.
  -> Seq TextLine  -- ^ The TextLines to align.
  -> Seq TextLine  -- ^ The aligned TextLines.
alignTextLines :: StyleState -> Rect -> Seq TextLine -> Seq TextLine
alignTextLines StyleState
style Rect
parentRect Seq TextLine
textLines = Seq TextLine
newTextLines where
  Rect Double
_ Double
py Double
_ Double
ph = Rect
parentRect
  Size Double
_ Double
th = Seq TextLine -> Size
getTextLinesSize Seq TextLine
textLines
  TextMetrics Double
asc Double
_ Double
lineH Double
lowerX = (Seq TextLine
textLines forall s a. s -> Getting (First a) s a -> Maybe a
^? forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
0) forall s a. s -> Getting a s a -> a
^. forall a. Eq a => a -> Iso' (Maybe a) a
non forall a. Default a => a
def forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasMetrics s a => Lens' s a
L.metrics

  isSingle :: Bool
isSingle = forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq TextLine
textLines forall a. Eq a => a -> a -> Bool
== Int
1
  alignH :: AlignTH
alignH = StyleState -> AlignTH
styleTextAlignH StyleState
style
  alignV :: AlignTV
alignV = StyleState -> AlignTV
styleTextAlignV StyleState
style

  alignOffsetY :: Double
alignOffsetY = case AlignTV
alignV of
    AlignTV
ATTop -> Double
0
    AlignTV
ATAscender
      | Bool
isSingle -> (Double
ph forall a. Num a => a -> a -> a
- Double
asc) forall a. Fractional a => a -> a -> a
/ Double
2
    AlignTV
ATLowerX
      | Bool
isSingle -> (Double
ph forall a. Num a => a -> a -> a
- Double
lowerX) forall a. Fractional a => a -> a -> a
/ Double
2 forall a. Num a => a -> a -> a
- (Double
asc forall a. Num a => a -> a -> a
- Double
lowerX)
    AlignTV
ATBottom -> Double
ph forall a. Num a => a -> a -> a
- Double
th
    AlignTV
ATBaseline -> Double
ph forall a. Num a => a -> a -> a
- Double
th
    AlignTV
_ -> (Double
ph forall a. Num a => a -> a -> a
- Double
th) forall a. Fractional a => a -> a -> a
/ Double
2 -- ATMiddle

  offsetY :: Double
offsetY = Double
py forall a. Num a => a -> a -> a
+ Double
alignOffsetY
  newTextLines :: Seq TextLine
newTextLines = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rect -> Double -> AlignTH -> TextLine -> TextLine
alignTextLine Rect
parentRect Double
offsetY AlignTH
alignH) Seq TextLine
textLines

-- | Moves a Seq of TextLines by the given offset.
moveTextLines
  :: Point         -- ^ The offset.
  -> Seq TextLine  -- ^ The TextLines.
  -> Seq TextLine  -- ^ The displaced TextLines.
moveTextLines :: Point -> Seq TextLine -> Seq TextLine
moveTextLines (Point Double
offsetX Double
offsetY) Seq TextLine
textLines = Seq TextLine
newTextLines where
  moveTextLine :: b -> b
moveTextLine b
tl = b
tl
    forall a b. a -> (a -> b) -> b
& forall s a. HasRect s a => Lens' s a
L.rect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasX s a => Lens' s a
L.x forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Double
offsetX
    forall a b. a -> (a -> b) -> b
& forall s a. HasRect s a => Lens' s a
L.rect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasY s a => Lens' s a
L.y forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ Double
offsetY
  newTextLines :: Seq TextLine
newTextLines = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {b} {a}.
(HasRect b a, HasX a Double, HasY a Double) =>
b -> b
moveTextLine Seq TextLine
textLines

-- | Returns the combined size of a sequence of text lines.
getTextLinesSize :: Seq TextLine -> Size
getTextLinesSize :: Seq TextLine -> Size
getTextLinesSize Seq TextLine
textLines = Size
size where
  -- Excludes last line vertical spacing
  spaceV :: Double
spaceV = FontSpace -> Double
unFontSpace forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Default a => a
def TextLine -> FontSpace
_tlFontSpaceV (Seq TextLine
textLines forall s a. s -> Getting (First a) s a -> Maybe a
^? forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
0)
  lineW :: s -> a
lineW s
line = s
line forall s a. s -> Getting a s a -> a
^. forall s a. HasSize s a => Lens' s a
L.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasW s a => Lens' s a
L.w
  lineH :: TextLine -> Double
lineH TextLine
line = TextLine
line forall s a. s -> Getting a s a -> a
^. forall s a. HasSize s a => Lens' s a
L.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasH s a => Lens' s a
L.h forall a. Num a => a -> a -> a
+ FontSpace -> Double
unFontSpace (TextLine -> FontSpace
_tlFontSpaceV TextLine
line)
  ~Double
width = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {s} {a} {a}. (HasSize s a, HasW a a) => s -> a
lineW Seq TextLine
textLines)
  height :: Double
height = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextLine -> Double
lineH Seq TextLine
textLines) forall a. Num a => a -> a -> a
- Double
spaceV
  size :: Size
size
    | forall a. Seq a -> Bool
Seq.null Seq TextLine
textLines = forall a. Default a => a
def
    | Bool
otherwise = Double -> Double -> Size
Size Double
width Double
height

-- | Gets the minimum x a Seq of Glyphs will use.
getGlyphsMin :: Seq GlyphPos -> Double
getGlyphsMin :: Seq GlyphPos -> Double
getGlyphsMin Seq GlyphPos
Empty = Double
0
getGlyphsMin (GlyphPos
g :<| Seq GlyphPos
gs) = GlyphPos -> Double
_glpXMin GlyphPos
g

-- | Gets the maximum x a Seq of Glyphs will use.
getGlyphsMax :: Seq GlyphPos -> Double
getGlyphsMax :: Seq GlyphPos -> Double
getGlyphsMax Seq GlyphPos
Empty = Double
0
getGlyphsMax (Seq GlyphPos
gs :|> GlyphPos
g) = GlyphPos -> Double
_glpXMax GlyphPos
g

-- Helpers
alignTextLine :: Rect -> Double -> AlignTH -> TextLine -> TextLine
alignTextLine :: Rect -> Double -> AlignTH -> TextLine -> TextLine
alignTextLine Rect
parentRect Double
offsetY AlignTH
alignH TextLine
textLine = TextLine
newTextLine where
  Rect Double
px Double
_ Double
pw Double
_ = Rect
parentRect
  Rect Double
tx Double
ty Double
tw Double
th = TextLine -> Rect
_tlRect TextLine
textLine

  alignOffsetX :: Double
alignOffsetX = case AlignTH
alignH of
    AlignTH
ATLeft -> Double
0
    AlignTH
ATCenter -> (Double
pw forall a. Num a => a -> a -> a
- Double
tw) forall a. Fractional a => a -> a -> a
/ Double
2
    AlignTH
ATRight -> Double
pw forall a. Num a => a -> a -> a
- Double
tw

  offsetX :: Double
offsetX = Double
px forall a. Num a => a -> a -> a
+ Double
alignOffsetX
  newTextLine :: TextLine
newTextLine = TextLine
textLine {
    _tlRect :: Rect
_tlRect = Double -> Double -> Double -> Double -> Rect
Rect (Double
tx forall a. Num a => a -> a -> a
+ Double
offsetX) (Double
ty forall a. Num a => a -> a -> a
+ Double
offsetY) Double
tw Double
th
  }

fitLinesToH
  :: FontManager
  -> StyleState
  -> TextOverflow
  -> Double
  -> Double
  -> Seq TextLine
  -> Seq TextLine
fitLinesToH :: FontManager
-> StyleState
-> TextOverflow
-> Double
-> Double
-> Seq TextLine
-> Seq TextLine
fitLinesToH FontManager
fontMgr StyleState
style TextOverflow
overflow Double
w Double
h Seq TextLine
Empty = forall a. Seq a
Empty
fitLinesToH FontManager
fontMgr StyleState
style TextOverflow
overflow Double
w Double
h (TextLine
g1 :<| TextLine
g2 :<| Seq TextLine
gs)
  | TextOverflow
overflow forall a. Eq a => a -> a -> Bool
== TextOverflow
Ellipsis Bool -> Bool -> Bool
&& Double
h forall a. Ord a => a -> a -> Bool
>= Double
g1H forall a. Num a => a -> a -> a
+ Double
g2H = TextLine
g1 forall a. a -> Seq a -> Seq a
:<| Seq TextLine
rest
  | TextOverflow
overflow forall a. Eq a => a -> a -> Bool
== TextOverflow
Ellipsis Bool -> Bool -> Bool
&& Double
h forall a. Ord a => a -> a -> Bool
>= Double
g1H = forall a. a -> Seq a
Seq.singleton TextLine
ellipsisG1
  | TextOverflow
overflow forall a. Eq a => a -> a -> Bool
== TextOverflow
ClipText Bool -> Bool -> Bool
&& Double
h forall a. Ord a => a -> a -> Bool
>= Double
g1H = TextLine
g1 forall a. a -> Seq a -> Seq a
:<| Seq TextLine
rest
  where
    g1H :: Double
g1H = Size -> Double
_sH (TextLine -> Size
_tlSize TextLine
g1)
    g2H :: Double
g2H = Size -> Double
_sH (TextLine -> Size
_tlSize TextLine
g2)
    newH :: Double
newH = Double
h forall a. Num a => a -> a -> a
- Double
g1H
    rest :: Seq TextLine
rest = FontManager
-> StyleState
-> TextOverflow
-> Double
-> Double
-> Seq TextLine
-> Seq TextLine
fitLinesToH FontManager
fontMgr StyleState
style TextOverflow
overflow Double
w Double
newH (TextLine
g2 forall a. a -> Seq a -> Seq a
:<| Seq TextLine
gs)
    ellipsisG1 :: TextLine
ellipsisG1 = FontManager -> StyleState -> Double -> TextLine -> TextLine
addEllipsisToTextLine FontManager
fontMgr StyleState
style Double
w TextLine
g1
fitLinesToH FontManager
fontMgr StyleState
style TextOverflow
overflow Double
w Double
h (TextLine
g :<| Seq TextLine
gs)
  | Double
h forall a. Ord a => a -> a -> Bool
> Double
0 = forall a. a -> Seq a
Seq.singleton TextLine
newG
  | Bool
otherwise = forall a. Seq a
Empty
  where
    gW :: Double
gW = Size -> Double
_sW (TextLine -> Size
_tlSize TextLine
g)
    newG :: TextLine
newG
      | TextOverflow
overflow forall a. Eq a => a -> a -> Bool
== TextOverflow
Ellipsis Bool -> Bool -> Bool
&& Double
w forall a. Ord a => a -> a -> Bool
< Double
gW = FontManager -> StyleState -> Double -> TextLine -> TextLine
addEllipsisToTextLine FontManager
fontMgr StyleState
style Double
w TextLine
g
      | Bool
otherwise = TextLine
g

fitLineToW
  :: FontManager
  -> Font
  -> FontSize
  -> FontSpace
  -> FontSpace
  -> TextMetrics
  -> LineBreak
  -> Double
  -> Double
  -> TextTrim
  -> Text
  -> Seq TextLine
fitLineToW :: FontManager
-> Font
-> FontSize
-> FontSpace
-> FontSpace
-> TextMetrics
-> LineBreak
-> Double
-> Double
-> TextTrim
-> Text
-> Seq TextLine
fitLineToW FontManager
fontMgr Font
font FontSize
fSize FontSpace
fSpcH FontSpace
fSpcV TextMetrics
metrics LineBreak
break Double
top Double
width TextTrim
trim Text
text = Seq TextLine
res where
  spaces :: Text
spaces = Int -> Text -> Text
T.replicate Int
4 Text
" "
  newText :: Text
newText = Text -> Text -> Text -> Text
T.replace Text
"\t" Text
spaces Text
text
  !glyphs :: Seq GlyphPos
glyphs = FontManager
-> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos FontManager
fontMgr Font
font FontSize
fSize FontSpace
fSpcH Text
newText
  -- Do not break line on trailing spaces, they are removed in the next step
  -- In the case of KeepSpaces, lines with only spaces (empty looking) are valid
  keepTailSpaces :: Bool
keepTailSpaces = TextTrim
trim forall a. Eq a => a -> a -> Bool
== TextTrim
TrimSpaces
  groups :: Seq (Seq GlyphPos)
groups
    | LineBreak
break forall a. Eq a => a -> a -> Bool
== LineBreak
OnCharacters = LineBreak -> Double -> Seq GlyphPos -> Seq (Seq GlyphPos)
splitGroups LineBreak
break Double
width Seq GlyphPos
glyphs
    | Bool
otherwise = Seq (Seq GlyphPos) -> Double -> Bool -> Seq (Seq GlyphPos)
fitGroups (LineBreak -> Double -> Seq GlyphPos -> Seq (Seq GlyphPos)
splitGroups LineBreak
break Double
width Seq GlyphPos
glyphs) Double
width Bool
keepTailSpaces
  resetGroups :: Seq (Seq GlyphPos)
resetGroups
    | TextTrim
trim forall a. Eq a => a -> a -> Bool
== TextTrim
TrimSpaces = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Seq GlyphPos -> Seq GlyphPos
trimGlyphs Seq (Seq GlyphPos)
groups
    | Bool
otherwise = Seq (Seq GlyphPos)
groups
  buildLine :: Int -> Seq GlyphPos -> TextLine
buildLine = Font
-> FontSize
-> FontSpace
-> FontSpace
-> TextMetrics
-> Double
-> Int
-> Seq GlyphPos
-> TextLine
buildTextLine Font
font FontSize
fSize FontSpace
fSpcH FontSpace
fSpcV TextMetrics
metrics Double
top
  res :: Seq TextLine
res
    | Text
text forall a. Eq a => a -> a -> Bool
/= Text
"" = forall a b. (Int -> a -> b) -> Seq a -> Seq b
Seq.mapWithIndex Int -> Seq GlyphPos -> TextLine
buildLine Seq (Seq GlyphPos)
resetGroups
    | Bool
otherwise = forall a. a -> Seq a
Seq.singleton (Int -> Seq GlyphPos -> TextLine
buildLine Int
0 forall a. Seq a
Empty)

buildTextLine
  :: Font
  -> FontSize
  -> FontSpace
  -> FontSpace
  -> TextMetrics
  -> Double
  -> Int
  -> Seq GlyphPos
  -> TextLine
buildTextLine :: Font
-> FontSize
-> FontSpace
-> FontSpace
-> TextMetrics
-> Double
-> Int
-> Seq GlyphPos
-> TextLine
buildTextLine Font
font FontSize
fSize FontSpace
fSpcH FontSpace
fSpcV TextMetrics
metrics Double
top Int
idx Seq GlyphPos
glyphs = TextLine
textLine where
  lineH :: Double
lineH = TextMetrics -> Double
_txmLineH TextMetrics
metrics
  x :: Double
x = Double
0
  y :: Double
y = Double
top forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx forall a. Num a => a -> a -> a
* (Double
lineH forall a. Num a => a -> a -> a
+ FontSpace -> Double
unFontSpace FontSpace
fSpcV)
  width :: Double
width = Seq GlyphPos -> Double
getGlyphsWidth Seq GlyphPos
glyphs
  height :: Double
height = Double
lineH
  text :: Text
text = [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[Char]
ac GlyphPos
g -> GlyphPos -> Char
_glpGlyph GlyphPos
g forall a. a -> [a] -> [a]
: [Char]
ac) [] Seq GlyphPos
glyphs
  textLine :: TextLine
textLine = TextLine {
    _tlFont :: Font
_tlFont = Font
font,
    _tlFontSize :: FontSize
_tlFontSize = FontSize
fSize,
    _tlFontSpaceH :: FontSpace
_tlFontSpaceH = FontSpace
fSpcH,
    _tlFontSpaceV :: FontSpace
_tlFontSpaceV = FontSpace
fSpcV,
    _tlMetrics :: TextMetrics
_tlMetrics = TextMetrics
metrics,
    _tlText :: Text
_tlText = Text
text,
    _tlSize :: Size
_tlSize = Double -> Double -> Size
Size Double
width Double
height,
    _tlRect :: Rect
_tlRect = Double -> Double -> Double -> Double -> Rect
Rect Double
x Double
y Double
width Double
height,
    _tlGlyphs :: Seq GlyphPos
_tlGlyphs = Seq GlyphPos
glyphs
  }

addEllipsisToTextLine
  :: FontManager
  -> StyleState
  -> Double
  -> TextLine
  -> TextLine
addEllipsisToTextLine :: FontManager -> StyleState -> Double -> TextLine -> TextLine
addEllipsisToTextLine FontManager
fontMgr StyleState
style Double
width TextLine
textLine = TextLine
newTextLine where
  TextLine{Text
Seq GlyphPos
Rect
Size
TextMetrics
FontSpace
FontSize
Font
_tlGlyphs :: Seq GlyphPos
_tlRect :: Rect
_tlSize :: Size
_tlText :: Text
_tlMetrics :: TextMetrics
_tlFontSpaceV :: FontSpace
_tlFontSpaceH :: FontSpace
_tlFontSize :: FontSize
_tlFont :: Font
_tlGlyphs :: TextLine -> Seq GlyphPos
_tlText :: TextLine -> Text
_tlMetrics :: TextLine -> TextMetrics
_tlFontSpaceH :: TextLine -> FontSpace
_tlFontSize :: TextLine -> FontSize
_tlFont :: TextLine -> Font
_tlSize :: TextLine -> Size
_tlRect :: TextLine -> Rect
_tlFontSpaceV :: TextLine -> FontSpace
..} = TextLine
textLine
  Size Double
tw Double
th = Size
_tlSize
  Size Double
dw Double
dh = FontManager -> StyleState -> Text -> Size
calcTextSize FontManager
fontMgr StyleState
style Text
"..."

  font :: Font
font = StyleState -> Font
styleFont StyleState
style
  fontSize :: FontSize
fontSize = StyleState -> FontSize
styleFontSize StyleState
style
  fontSpcH :: FontSpace
fontSpcH = StyleState -> FontSpace
styleFontSpaceH StyleState
style
  targetW :: Double
targetW = Double
width forall a. Num a => a -> a -> a
- Double
tw

  dropHelper :: (a, Double) -> GlyphPos -> (a, Double)
dropHelper (a
idx, Double
w) GlyphPos
g
    | Double -> Double -> Bool
isSafeLE (GlyphPos -> Double
_glpW GlyphPos
g forall a. Num a => a -> a -> a
+ Double
w) Double
dw = (a
idx forall a. Num a => a -> a -> a
+ a
1, GlyphPos -> Double
_glpW GlyphPos
g forall a. Num a => a -> a -> a
+ Double
w)
    | Bool
otherwise = (a
idx, Double
w)
  (Int
dropChars, Double
_) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Num a => (a, Double) -> GlyphPos -> (a, Double)
dropHelper (Int
0, Double
targetW) (forall a. Seq a -> Seq a
Seq.reverse Seq GlyphPos
_tlGlyphs)

  newText :: Text
newText = Int -> Text -> Text
T.dropEnd Int
dropChars Text
_tlText forall a. Semigroup a => a -> a -> a
<> Text
"..."
  !newGlyphs :: Seq GlyphPos
newGlyphs = FontManager
-> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos FontManager
fontMgr Font
font FontSize
fontSize FontSpace
fontSpcH Text
newText

  newW :: Double
newW = Seq GlyphPos -> Double
getGlyphsWidth Seq GlyphPos
newGlyphs
  newTextLine :: TextLine
newTextLine = TextLine
textLine {
    _tlText :: Text
_tlText = Text
newText,
    _tlSize :: Size
_tlSize = Size
_tlSize { _sW :: Double
_sW = Double
newW },
    _tlRect :: Rect
_tlRect = Rect
_tlRect { _rW :: Double
_rW = Double
newW },
    _tlGlyphs :: Seq GlyphPos
_tlGlyphs = Seq GlyphPos
newGlyphs
  }

clipTextLine
  :: FontManager
  -> StyleState
  -> TextTrim
  -> Double
  -> TextLine
  -> TextLine
clipTextLine :: FontManager
-> StyleState -> TextTrim -> Double -> TextLine -> TextLine
clipTextLine FontManager
fontMgr StyleState
style TextTrim
trim Double
width TextLine
textLine = TextLine
newTextLine where
  TextLine{Text
Seq GlyphPos
Rect
Size
TextMetrics
FontSpace
FontSize
Font
_tlGlyphs :: Seq GlyphPos
_tlRect :: Rect
_tlSize :: Size
_tlText :: Text
_tlMetrics :: TextMetrics
_tlFontSpaceV :: FontSpace
_tlFontSpaceH :: FontSpace
_tlFontSize :: FontSize
_tlFont :: Font
_tlGlyphs :: TextLine -> Seq GlyphPos
_tlText :: TextLine -> Text
_tlMetrics :: TextLine -> TextMetrics
_tlFontSpaceH :: TextLine -> FontSpace
_tlFontSize :: TextLine -> FontSize
_tlFont :: TextLine -> Font
_tlSize :: TextLine -> Size
_tlRect :: TextLine -> Rect
_tlFontSpaceV :: TextLine -> FontSpace
..} = TextLine
textLine
  Size Double
tw Double
th = Size
_tlSize

  font :: Font
font = StyleState -> Font
styleFont StyleState
style
  fontSize :: FontSize
fontSize = StyleState -> FontSize
styleFontSize StyleState
style
  fontSpcH :: FontSpace
fontSpcH = StyleState -> FontSpace
styleFontSpaceH StyleState
style

  takeHelper :: (a, Double) -> GlyphPos -> (a, Double)
takeHelper (a
idx, Double
w) GlyphPos
g
    | Double -> Double -> Bool
isSafeLE (GlyphPos -> Double
_glpW GlyphPos
g forall a. Num a => a -> a -> a
+ Double
w) Double
width = (a
idx forall a. Num a => a -> a -> a
+ a
1, GlyphPos -> Double
_glpW GlyphPos
g forall a. Num a => a -> a -> a
+ Double
w)
    | Bool
otherwise = (a
idx, Double
w)

  (Integer
takeChars, Double
_) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Num a => (a, Double) -> GlyphPos -> (a, Double)
takeHelper (Integer
0, Double
0) Seq GlyphPos
_tlGlyphs
  validGlyphs :: Seq GlyphPos
validGlyphs = forall a. (a -> Bool) -> Seq a -> Seq a
Seq.takeWhileL (\GlyphPos
g -> Double -> Double -> Bool
isSafeLE (GlyphPos -> Double
_glpXMax GlyphPos
g) Double
width) Seq GlyphPos
_tlGlyphs
  newText :: Text
newText
    | TextTrim
trim forall a. Eq a => a -> a -> Bool
== TextTrim
KeepSpaces = Int -> Text -> Text
T.take (forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq GlyphPos
validGlyphs) Text
_tlText
    | Bool
otherwise = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
' ') forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.take (forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq GlyphPos
validGlyphs) Text
_tlText

  !newGlyphs :: Seq GlyphPos
newGlyphs = FontManager
-> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos FontManager
fontMgr Font
font FontSize
fontSize FontSpace
fontSpcH Text
newText
  newW :: Double
newW = Seq GlyphPos -> Double
getGlyphsWidth Seq GlyphPos
newGlyphs
  newTextLine :: TextLine
newTextLine = TextLine
textLine {
    _tlText :: Text
_tlText = Text
newText,
    _tlSize :: Size
_tlSize = Size
_tlSize { _sW :: Double
_sW = Double
newW },
    _tlRect :: Rect
_tlRect = Rect
_tlRect { _rW :: Double
_rW = Double
newW },
    _tlGlyphs :: Seq GlyphPos
_tlGlyphs = Seq GlyphPos
newGlyphs
  }

fitGroups :: Seq GlyphGroup -> Double -> Bool -> Seq GlyphGroup
fitGroups :: Seq (Seq GlyphPos) -> Double -> Bool -> Seq (Seq GlyphPos)
fitGroups Seq (Seq GlyphPos)
Empty Double
_ Bool
_ = forall a. Seq a
Empty
fitGroups (Seq GlyphPos
g :<| Seq (Seq GlyphPos)
gs) !Double
width !Bool
keepTailSpaces = Seq GlyphPos
currentLine forall a. a -> Seq a -> Seq a
<| Seq (Seq GlyphPos)
extraLines where
  gW :: Double
gW = Seq GlyphPos -> Double
getGlyphsWidth Seq GlyphPos
g
  gMax :: Double
gMax = Seq GlyphPos -> Double
getGlyphsMax Seq GlyphPos
g
  extraGroups :: (Seq GlyphPos, Seq (Seq GlyphPos))
extraGroups = Seq (Seq GlyphPos)
-> Double -> Double -> Bool -> (Seq GlyphPos, Seq (Seq GlyphPos))
fitExtraGroups Seq (Seq GlyphPos)
gs (Double
width forall a. Num a => a -> a -> a
- Double
gW) Double
gMax Bool
keepTailSpaces
  (Seq GlyphPos
lineGroups, Seq (Seq GlyphPos)
remainingGroups) = (Seq GlyphPos, Seq (Seq GlyphPos))
extraGroups
  currentLine :: Seq GlyphPos
currentLine = Seq GlyphPos
g forall a. Semigroup a => a -> a -> a
<> Seq GlyphPos
lineGroups
  extraLines :: Seq (Seq GlyphPos)
extraLines = Seq (Seq GlyphPos) -> Double -> Bool -> Seq (Seq GlyphPos)
fitGroups Seq (Seq GlyphPos)
remainingGroups Double
width Bool
keepTailSpaces

fitExtraGroups
  :: Seq GlyphGroup
  -> Double
  -> Double
  -> Bool
  -> (Seq GlyphPos, Seq GlyphGroup)
fitExtraGroups :: Seq (Seq GlyphPos)
-> Double -> Double -> Bool -> (Seq GlyphPos, Seq (Seq GlyphPos))
fitExtraGroups Seq (Seq GlyphPos)
Empty Double
_ Double
_ Bool
_ = (forall a. Seq a
Empty, forall a. Seq a
Empty)
fitExtraGroups (Seq GlyphPos
g :<| Seq (Seq GlyphPos)
gs) !Double
width !Double
prevGMax !Bool
keepTailSpaces
  | Double -> Double -> Bool
isSafeLE (Double
gW forall a. Num a => a -> a -> a
+ Double
wDiff) Double
width Bool -> Bool -> Bool
|| Bool
keepSpace = (Seq GlyphPos
g forall a. Semigroup a => a -> a -> a
<> Seq GlyphPos
newFit, Seq (Seq GlyphPos)
newRest)
  | Bool
otherwise = (forall a. Seq a
Empty, Seq GlyphPos
g forall a. a -> Seq a -> Seq a
:<| Seq (Seq GlyphPos)
gs)
  where
    gW :: Double
gW = Seq GlyphPos -> Double
getGlyphsWidth Seq GlyphPos
g
    gMin :: Double
gMin = Seq GlyphPos -> Double
getGlyphsMin Seq GlyphPos
g
    gMax :: Double
gMax = Seq GlyphPos -> Double
getGlyphsMax Seq GlyphPos
g
    wDiff :: Double
wDiff = Double
gMin forall a. Num a => a -> a -> a
- Double
prevGMax
    remWidth :: Double
remWidth = Double
width forall a. Num a => a -> a -> a
- (Double
gW forall a. Num a => a -> a -> a
+ Double
wDiff)
    keepSpace :: Bool
keepSpace = Bool
keepTailSpaces Bool -> Bool -> Bool
&& Seq GlyphPos -> Bool
isSpaceGroup Seq GlyphPos
g
    (Seq GlyphPos
newFit, Seq (Seq GlyphPos)
newRest) = Seq (Seq GlyphPos)
-> Double -> Double -> Bool -> (Seq GlyphPos, Seq (Seq GlyphPos))
fitExtraGroups Seq (Seq GlyphPos)
gs Double
remWidth Double
gMax Bool
keepTailSpaces

getGlyphsWidth :: Seq GlyphPos -> Double
getGlyphsWidth :: Seq GlyphPos -> Double
getGlyphsWidth Seq GlyphPos
glyphs = Seq GlyphPos -> Double
getGlyphsMax Seq GlyphPos
glyphs forall a. Num a => a -> a -> a
- Seq GlyphPos -> Double
getGlyphsMin Seq GlyphPos
glyphs

isSpaceGroup :: Seq GlyphPos -> Bool
isSpaceGroup :: Seq GlyphPos -> Bool
isSpaceGroup Seq GlyphPos
Empty = Bool
False
isSpaceGroup (GlyphPos
g :<| Seq GlyphPos
gs) = Char -> Bool
isSpace (GlyphPos -> Char
_glpGlyph GlyphPos
g)

splitGroups :: LineBreak -> Double -> Seq GlyphPos -> Seq GlyphGroup
splitGroups :: LineBreak -> Double -> Seq GlyphPos -> Seq (Seq GlyphPos)
splitGroups LineBreak
_ Double
_ Seq GlyphPos
Empty = forall a. Seq a
Empty
splitGroups LineBreak
break Double
width Seq GlyphPos
glyphs = Seq GlyphPos
group forall a. a -> Seq a -> Seq a
<| LineBreak -> Double -> Seq GlyphPos -> Seq (Seq GlyphPos)
splitGroups LineBreak
break Double
width Seq GlyphPos
rest where
  GlyphPos
g :<| Seq GlyphPos
gs = Seq GlyphPos
glyphs
  groupWordFn :: GlyphPos -> Bool
groupWordFn = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isWordDelimiter forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlyphPos -> Char
_glpGlyph
  groupWidthFn :: GlyphPos -> Bool
groupWidthFn GlyphPos
g2 = GlyphPos -> Double
_glpXMax GlyphPos
g2 forall a. Num a => a -> a -> a
- GlyphPos -> Double
_glpXMin GlyphPos
g forall a. Ord a => a -> a -> Bool
<= Double
width
  atWord :: Bool
atWord = LineBreak
break forall a. Eq a => a -> a -> Bool
== LineBreak
OnSpaces
  (Seq GlyphPos
group, Seq GlyphPos
rest)
    | Bool
atWord Bool -> Bool -> Bool
&& Char -> Bool
isWordDelimiter (GlyphPos -> Char
_glpGlyph GlyphPos
g) = (forall a. a -> Seq a
Seq.singleton GlyphPos
g, Seq GlyphPos
gs)
    | Bool
atWord = forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.spanl GlyphPos -> Bool
groupWordFn Seq GlyphPos
glyphs
    | Bool
otherwise = forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.spanl GlyphPos -> Bool
groupWidthFn Seq GlyphPos
glyphs

trimGlyphs :: Seq GlyphPos -> Seq GlyphPos
trimGlyphs :: Seq GlyphPos -> Seq GlyphPos
trimGlyphs Seq GlyphPos
glyphs = Seq GlyphPos
newGlyphs where
  isSpaceGlyph :: GlyphPos -> Bool
isSpaceGlyph GlyphPos
g = GlyphPos -> Char
_glpGlyph GlyphPos
g forall a. Eq a => a -> a -> Bool
== Char
' '
  newGlyphs :: Seq GlyphPos
newGlyphs = forall a. (a -> Bool) -> Seq a -> Seq a
Seq.dropWhileL GlyphPos -> Bool
isSpaceGlyph forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Seq a -> Seq a
Seq.dropWhileR GlyphPos -> Bool
isSpaceGlyph Seq GlyphPos
glyphs

isWordDelimiter :: Char -> Bool
isWordDelimiter :: Char -> Bool
isWordDelimiter = (forall a. Eq a => a -> a -> Bool
== Char
' ')

isSpace :: Char -> Bool
isSpace :: Char -> Bool
isSpace = (forall a. Eq a => a -> a -> Bool
== Char
' ')

isSafeLE :: Double -> Double -> Bool
isSafeLE :: Double -> Double -> Bool
isSafeLE Double
width Double
target = Double
width forall a. Ord a => a -> a -> Bool
<= Double
target Bool -> Bool -> Bool
|| forall a. Num a => a -> a
abs (Double
target forall a. Num a => a -> a -> a
- Double
width) forall a. Ord a => a -> a -> Bool
< Double
0.001