module Data.Text.ParagraphLayout.Internal.Plain (Paragraph(..) ,ParagraphLayout(..) ,ParagraphOptions(..) ,SpanLayout(..) ,layoutPlain ) where import Control.Applicative (ZipList(ZipList), getZipList) import Data.Int (Int32) import Data.List (mapAccumL) import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NonEmpty import Data.Text.Foreign (lengthWord8) import Data.Text.Glyphize (Buffer(..) ,ContentType(ContentTypeUnicode) ,Direction(..) ,FontExtents(..) ,GlyphInfo ,GlyphPos ,defaultBuffer ,fontExtentsForDir ,shape ) import Data.Text.ICU (Breaker, LocaleName, breakCharacter, breakLine) import qualified Data.Text.ICU as BreakStatus (Line) import Data.Text.Internal (Text(Text)) import qualified Data.Text.Lazy as Lazy import Data.Text.ParagraphLayout.Internal.Break import Data.Text.ParagraphLayout.Internal.Fragment import Data.Text.ParagraphLayout.Internal.LineHeight import Data.Text.ParagraphLayout.Internal.Paragraph import qualified Data.Text.ParagraphLayout.Internal.ProtoFragment as PF import Data.Text.ParagraphLayout.Internal.Rect import Data.Text.ParagraphLayout.Internal.ResolvedSpan (WithSpan(WithSpan)) import qualified Data.Text.ParagraphLayout.Internal.ResolvedSpan as RS import Data.Text.ParagraphLayout.Internal.Run import Data.Text.ParagraphLayout.Internal.Span import Data.Text.ParagraphLayout.Internal.TextContainer -- | Lay out a paragraph of plain, unidirectional text using a single font. layoutPlain :: Paragraph -> ParagraphLayout layoutPlain p@(Paragraph _ _ _ opts) = paragraphLayout sls where sls = map SpanLayout fragsBySpan fragsBySpan = take (length spans) $ RS.splitBySpanIndex frags frags = layoutAndAlignLines maxWidth $ spansToRunsWrapped spans maxWidth = paragraphMaxWidth opts spans = resolveSpans p -- | Split a number of spans into a flat array of runs and add a wrapper -- so that each run can be traced back to its originating span. spansToRunsWrapped :: [RS.ResolvedSpan] -> [WithSpan Run] spansToRunsWrapped ss = concat $ map spanToRunsWrapped ss -- | Split a span into runs and add a wrapper -- so that each run can be traced back to its originating span. spanToRunsWrapped :: RS.ResolvedSpan -> [WithSpan Run] spanToRunsWrapped s = map (WithSpan s) (spanToRuns s) -- | Create a multi-line layout from the given runs, splitting them as -- necessary to fit within the requested line width. -- -- The output is a flat list of fragments positioned in both dimensions. layoutAndAlignLines :: Int32 -> [WithSpan Run] -> [WithSpan Fragment] layoutAndAlignLines maxWidth runs = frags where frags = concat fragsInLines (_, fragsInLines) = mapAccumL positionLineH originY canonicalLines canonicalLines = map canonicalOrder logicalLines logicalLines = layoutLines maxWidth runs originY = paragraphOriginY -- | Reorder the given fragments from logical order to whatever order HarfBuzz -- uses (LTR for horizontal text, TTB for vertical text), so that cluster order -- is preserved even across runs. canonicalOrder :: [WithSpan PF.ProtoFragment] -> [WithSpan PF.ProtoFragment] canonicalOrder [] = [] canonicalOrder pfs@((WithSpan _ headPF):_) = case PF.direction headPF of -- TODO: Update for bidi. Just DirLTR -> pfs Just DirRTL -> reverse pfs Just DirTTB -> pfs Just DirBTT -> reverse pfs -- If no guess can be made, use LTR. -- TODO: Add explicit direction to input interface. Nothing -> pfs -- | Create a multi-line layout from the given runs, splitting them as -- necessary to fit within the requested line width. -- -- The output is a two-dimensional list of fragments positioned along the -- horizontal axis. layoutLines :: Int32 -> [WithSpan Run] -> [[WithSpan PF.ProtoFragment]] layoutLines maxWidth runs | null rest -- Everything fits. We are done. = fitting : [] | otherwise -- Something fits, the rest goes on the next line. = fitting : layoutLines maxWidth rest where (fitting, rest) = layoutAndWrapRunsH maxWidth runs -- TODO: Allow a run across multiple spans (e.g. if they only differ by colour). -- | Position all the given horizontal fragments on the same line, -- using `originY` as its top edge, and return the bottom edge for continuation. -- -- Glyphs will be aligned by their ascent line, similar to the behaviour of -- @vertical-align: top@ in CSS. -- -- TODO: For rich text, allow other types of vertical alignment. positionLineH :: Int32 -> [WithSpan PF.ProtoFragment] -> (Int32, [WithSpan Fragment]) positionLineH originY pfs = (nextY, frags) where -- A line with no glyphs will be considered to have zero height. -- This can happen when line breaking produces a line that contains -- onls spaces. nextY = if null rects then originY else maximum $ map y_min rects rects = map (\(WithSpan _ r) -> fragmentRect r) frags frags = snd $ mapAccumL (positionFragmentH originY) originX pfs originX = paragraphOriginX -- | Position the given horizontal fragment on a line, -- using `originY` as its top edge and `originX` as its left edge, -- returning the X coordinate of its right edge for continuation. positionFragmentH :: Int32 -> Int32 -> WithSpan PF.ProtoFragment -> (Int32, WithSpan Fragment) positionFragmentH originY originX (WithSpan rs pf) = (nextX, WithSpan rs frag) where nextX = originX + PF.advance pf frag = Fragment rect (penX, penY) (PF.glyphs pf) rect = Rect originX originY (PF.advance pf) (-lineHeight) penX = 0 penY = descent + leading `div` 2 - lineHeight lineHeight = case RS.spanLineHeight rs of Normal -> normalLineHeight Absolute h -> h leading = lineHeight - normalLineHeight normalLineHeight = ascent + descent ascent = ascender extents descent = - descender extents extents = fontExtentsForDir font (PF.direction pf) font = RS.spanFont rs -- | Calculate layout for multiple horizontal runs, breaking them as necessary -- to fit as much content as possible without exceeding the maximum line width, -- and return the remaining runs to be placed on other lines. layoutAndWrapRunsH :: Int32 -> [WithSpan Run] -> ([WithSpan PF.ProtoFragment], [WithSpan Run]) layoutAndWrapRunsH maxWidth runs = NonEmpty.head $ validLayouts where validLayouts = dropWhile1 tooLong layouts tooLong (pfs, _) = totalAdvances pfs > maxWidth layouts = NonEmpty.map layoutFst splits layoutFst (runs1, runs2) = (layout runs1, runs2) layout runs1 = layoutRunsH $ trimTextsEnd isEndSpace runs1 splits = noSplit :| (lSplits ++ cSplits) noSplit = (runs, []) -- TODO: Use Soft/Hard line break distinction. lSplits = splitTextsBy (map fst . runLineBreaks) runs cSplits = splitTextsBy (map fst . runCharacterBreaks) runs -- | The suffix remaining after removing the longest prefix of the list for -- which the predicate holds, except always including at least the last element -- of the original list. dropWhile1 :: (a -> Bool) -> NonEmpty a -> NonEmpty a dropWhile1 p list = case NonEmpty.uncons list of (_, Nothing) -> list (x, Just xs) -> if p x then dropWhile1 p xs else list -- | Calculate layout for multiple horizontal runs on the same line, without -- any breaking. layoutRunsH :: [WithSpan Run] -> [WithSpan PF.ProtoFragment] layoutRunsH runs = map layoutRunH runs -- | Sum of all advances within the given fragments. totalAdvances :: [WithSpan PF.ProtoFragment] -> Int32 totalAdvances pfs = sum $ map (\(WithSpan _ pf) -> PF.advance pf) pfs -- | Calculate layout for the given horizontal run and attach extra information. layoutRunH :: WithSpan Run -> WithSpan PF.ProtoFragment layoutRunH (WithSpan rs run) = WithSpan rs pf where pf = PF.protoFragmentH dir glyphs glyphs = shapeRun (WithSpan rs run) dir = runDirection run -- | Calculate layout for the given run independently of its position. shapeRun :: WithSpan Run -> [(GlyphInfo, GlyphPos)] shapeRun (WithSpan rs run) = shape font buffer features where font = RS.spanFont rs -- TODO: Set beginsText / endsText. buffer = defaultBuffer { text = Lazy.fromStrict $ runText run , contentType = Just ContentTypeUnicode , direction = runDirection run , script = runScript run , language = Just $ RS.spanLanguage rs } features = [] resolveSpans :: Paragraph -> [RS.ResolvedSpan] resolveSpans p@(Paragraph arr pStart spans pOpts) = do let sBounds = paragraphSpanBounds p let pEnd = NonEmpty.last sBounds let sStarts = NonEmpty.init sBounds let sLengths = map spanLength spans (i, s, sStart, sLen) <- getZipList $ (,,,) <$> ZipList [0..] <*> ZipList spans <*> ZipList sStarts <*> ZipList sLengths let lang = spanLanguage $ spanOptions s let lBreaks = paragraphBreaks breakLine p pEnd lang let cBreaks = paragraphBreaks breakCharacter p pEnd lang return RS.ResolvedSpan { RS.spanIndex = i , RS.spanOffsetInParagraph = sStart - pStart -- TODO: Consider adding checks for array bounds. , RS.spanText = Text arr sStart sLen , RS.spanFont = paragraphFont pOpts , RS.spanLineHeight = paragraphLineHeight pOpts , RS.spanLanguage = lang , RS.spanLineBreaks = subOffsetsDesc (sStart - pStart) lBreaks , RS.spanCharacterBreaks = subOffsetsDesc (sStart - pStart) cBreaks } paragraphBreaks :: (LocaleName -> Breaker a) -> Paragraph -> Int -> String -> [(Int, a)] paragraphBreaks breakFunc (Paragraph arr off _ _) end lang = breaksDesc (breakFunc (locale lang LBAuto)) paragraphText where paragraphText = Text arr off (end - off) runLineBreaks :: WithSpan Run -> [(Int, BreakStatus.Line)] runLineBreaks (WithSpan rs run) = runBreaksFromSpan run $ RS.spanLineBreaks rs runCharacterBreaks :: WithSpan Run -> [(Int, ())] runCharacterBreaks (WithSpan rs run) = runBreaksFromSpan run $ RS.spanCharacterBreaks rs -- | Constrain span breaks to a selected run and adjust offsets. runBreaksFromSpan :: Run -> [(Int, a)] -> [(Int, a)] runBreaksFromSpan run spanBreaks = dropWhile (not . valid) $ subOffsetsDesc (runOffsetInSpan run) spanBreaks where valid (off, _) = off < runLength runLength = lengthWord8 $ getText run -- | Predicate for characters that can be potentially removed from the end of -- a line according to the CSS Text Module. isEndSpace :: Char -> Bool isEndSpace c = c `elem` [' ', '\t', '\x1680']