ParagraphLayoutSpec.hs

module Data.Text.ParagraphLayoutSpec (spec) where

import Data.Text.Glyphize
    ( Font
    , FontOptions (optionPPEm, optionScale)
    , defaultFontOptions
    )

import Test.Hspec
import Test.Hspec.Golden
import System.FilePath ((</>))
import Data.Text.ParagraphLayout
import Data.Text.ParagraphLayout.FontLoader
import Data.Text.ParagraphLayout.Internal.Fragment
import Data.Text.ParagraphLayout.Internal.Plain.ParagraphLayout
import Data.Text.ParagraphLayout.ParagraphData
import Data.Text.ParagraphLayout.Rect

class PrettyShow a where
    prettyShow :: a -> String

newtype ShapedRuns = ShapedRuns { getShapedRuns :: [ShapedRun] }
    deriving (Eq)

instance PrettyShow ShapedRuns where
    prettyShow (ShapedRuns xs) = concat
        [ "["
        , concat $ indentedList indent0 $ map (prettyShow . ShapedRun') xs
        , "]"
        ]

newtype ShapedRun' = ShapedRun' ShapedRun

instance PrettyShow ShapedRun' where
    prettyShow (ShapedRun' (x, y, glyphs)) = concat
        [ "("
        , show x
        , ","
        , show y
        , ","
        , newline
        , indent1
        , "["
        , concat $ indentedList indent1 $ map show glyphs
        , "]"
        , newline
        , ")"
        ]

type Page = (PageContinuity, ParagraphLayout)

newtype Pages = Pages { getPages :: [Page] }
    deriving (Eq)

instance PrettyShow Pages where
    prettyShow (Pages ps) = concat
        [ "["
        , concat $ indentedList indent0 $ map (prettyShow . Page') ps
        , "]"
        ]

newtype Page' = Page' Page

instance PrettyShow Page' where
    prettyShow (Page' (c, pl)) = concat
        [ "("
        , show c
        , ", "
        , prettyShow pl
        , ")"
        ]

instance PrettyShow ParagraphLayout where
    prettyShow (ParagraphLayout pr sls) = concat
        [ "ParagraphLayout {paragraphRect = "
        , show pr
        , commaSpace
        , "spanLayouts = ["
        , newline
        , indent1
        , concat $ indentedList indent1 $ map prettyShow sls
        , newline
        , "]}"
        , newline
        ]

instance PrettyShow SpanLayout where
    prettyShow (SpanLayout frags) = concat
        [ "SpanLayout ["
        , concat $ inlineList $ map prettyShow frags
        , "]"
        ]

instance PrettyShow Fragment where
    prettyShow (Fragment r pen glyphs) = concat
        [ "Fragment {fragmentRect = "
        , show r
        , commaSpace
        , "fragmentPen = "
        , show pen
        , commaSpace
        , "fragmentGlyphs ="
        , newline
        , indent2
        , "["
        , concat $ indentedList indent2 $ map show glyphs
        , "]"
        , newline
        , indent1
        , "}"
        ]

inlineList :: [String] -> [String]
inlineList items = suffixInit commaSpace items

indentedList :: String -> [String] -> [String]
indentedList indent items = prefixTail indent $ suffixInit commaNewline items

suffixInit :: String -> [String] -> [String]
suffixInit suffix = mapInit (++ suffix)

mapInit :: (a -> a) -> [a] -> [a]
mapInit _ [] = []
mapInit _ [x] = [x]
mapInit f (x : y : ys) = f x : mapInit f (y : ys)

prefixTail :: String -> [String] -> [String]
prefixTail prefix = mapTail (prefix ++)

mapTail :: (a -> a) -> [a] -> [a]
mapTail _ [] = []
mapTail f (x : xs) = x : (map f xs)

indent0 :: String
indent0 = ""

indent1 :: String
indent1 = "    "

indent2 :: String
indent2 = indent1 ++ indent1

newline :: String
newline = "\n"

commaSpace :: String
commaSpace = ", "

commaNewline :: String
commaNewline = "," ++ newline

class ShouldBeGolden a where
    shouldBeGolden :: a -> FilePath -> Golden a

instance ShouldBeGolden ParagraphLayout where
    shouldBeGolden output_ name = Golden
        { output = output_
        , encodePretty = show
        , writeToFile = \ path -> writeFile path . prettyShow
        , readFromFile = \ path -> readFile path >>= return . read
        , goldenFile = ".golden" </> name </> "golden"
        , actualFile = Just (".golden" </> name </> "actual")
        , failFirstTime = True
        }

instance ShouldBeGolden Pages where
    shouldBeGolden output_ name = Golden
        { output = output_
        , encodePretty = show . getPages
        , writeToFile = \ path -> writeFile path . prettyShow
        , readFromFile = \ path -> readFile path >>= return . Pages . read
        , goldenFile = ".golden" </> name </> "golden"
        , actualFile = Just (".golden" </> name </> "actual")
        , failFirstTime = True
        }

instance ShouldBeGolden ShapedRuns where
    shouldBeGolden output_ name = Golden
        { output = output_
        , encodePretty = show . getShapedRuns
        , writeToFile = \ path -> writeFile path . prettyShow
        , readFromFile = \ path -> readFile path >>= return . ShapedRuns . read
        , goldenFile = ".golden" </> "shapedRuns" </> name </> "golden"
        , actualFile = Just (".golden" </> "shapedRuns" </> name </> "actual")
        , failFirstTime = True
        }

fontInfoPath :: String -> FilePath
fontInfoPath name = ".golden" </> "shapedRuns" </> name </> "fontInfo"

shapedRuns' :: ParagraphLayout -> ShapedRuns
shapedRuns' = ShapedRuns . shapedRuns

emptyLayout :: ParagraphLayout
emptyLayout = ParagraphLayout (Rect 0 0 0 0) []

emptySpanLayout :: ParagraphLayout
emptySpanLayout = ParagraphLayout (Rect 0 0 0 0) [SpanLayout []]

-- Test primarily with a high level of detail (1000 units per EM).
-- Hinting should behave as if the font size were 24px.
-- TODO: Test hinting.
testingOptions :: FontOptions
testingOptions = defaultFontOptions {
    optionPPEm = Just (24, 24),
    optionScale = Just (1000, 1000)
}

-- For the demo, use a 15px font size with exactly one scale unit per pixel.
demoOptions :: FontOptions
demoOptions = defaultFontOptions {
    optionPPEm = Just (15, 15),
    optionScale = Just (15, 15)
}

-- | Test shaped runs against an expected value, and write metadata about the
-- used font afterwards.
shapedRunsSpecWithFont ::
    FilePath -> Font -> String -> FilePath -> Paragraph -> SpecWith ()
shapedRunsSpecWithFont fontPath font subject name p = do
    let writeInfo = writeFontInfo (fontInfoPath name) fontPath font
    after_ writeInfo $ it subject $ do
        let result = layoutPlain p
        shapedRuns' result `shouldBeGolden` name

paginateAll :: PageOptions -> ParagraphLayout -> [Page]
paginateAll opts pl = case paginate opts pl of
    (c, pl1, next) -> (c, pl1) : case next of
        Just pl2 -> paginateAll opts' pl2
        Nothing -> []
    where
        opts' = opts { pageCurrentHeight = pageNextHeight opts }

spec :: Spec
spec = do

    describe "layoutPlain" $ do

        describe "with Arabic font" $ do
            font <- runIO $ loadFont arabicFont 0 testingOptions

            it "handles input with no spans" $ do
                let opts = ParagraphOptions font Normal 8000
                let result = layoutPlain $ emptyParagraph opts
                result `shouldBe` emptyLayout

            it "wraps filler text at 20em" $ do
                let opts = ParagraphOptions font Normal 20000
                let result = layoutPlain $ arabicFillerParagraph opts
                result `shouldBeGolden` "arabicFiller20em"

            it "wraps filler text with spans at 20em" $ do
                let opts = ParagraphOptions font Normal 20000
                let result = layoutPlain $ spannedArabicFillerParagraph opts
                result `shouldBeGolden` "spannedArabicFiller20em"

            it "spans do not reposition filler text at 20em" $ do
                let opts = ParagraphOptions font Normal 20000
                let withoutSpans = layoutPlain $ arabicFillerParagraph opts
                let withSpans = layoutPlain $ spannedArabicFillerParagraph opts
                paragraphRect withoutSpans `shouldBe` paragraphRect withSpans

            it "applies hard breaks correctly" $ do
                let opts = ParagraphOptions font Normal 6000
                let result = layoutPlain $ hardBreaksRTLParagraph opts
                result `shouldBeGolden` "hardBreaksRTLParagraph"

        describe "with Devanagari font" $ do
            font <- runIO $ loadFont devanagariFont 0 testingOptions

            describe "lone accent character" $ do
                let
                    opts = ParagraphOptions font Normal 8000
                    result = layoutPlain $
                        devanagariAccentParagraph opts

                it "inserts a dotted circle" $ do
                    x_size (paragraphRect result) `shouldBe` 645

                it "is golden" $ do
                    result `shouldBeGolden` "devanagariAccentParagraph"

            describe "lone accent character after prefix" $ do
                let
                    opts = ParagraphOptions font Normal 8000
                    result = layoutPlain $
                        devanagariPrefixedAccentParagraph opts

                it "does not insert a dotted circle" $ do
                    x_size (paragraphRect result) `shouldBe` 0

                it "is golden" $ do
                    result `shouldBeGolden` "devanagariPrefixedAccentParagraph"

            it "handles input without wrapping" $ do
                let opts = ParagraphOptions font Normal 9000
                let result = layoutPlain $ devanagariParagraph opts
                result `shouldBeGolden` "devanagariParagraph"

        describe "with Latin font" $ do
            -- Note: This font does not contain Japanese glyphs.
            font <- runIO $ loadFont latinFont 0 testingOptions

            it "handles input with no spans" $ do
                let opts = ParagraphOptions font Normal 8000
                let result = layoutPlain $ emptyParagraph opts
                result `shouldBe` emptyLayout

            it "handles one span with no text" $ do
                let opts = ParagraphOptions font Normal 8000
                let result = layoutPlain $ emptySpanParagraph opts
                result `shouldBe` emptySpanLayout

            it "handles Czech hello" $ do
                let opts = ParagraphOptions font Normal 8000
                let result = layoutPlain $ czechHelloParagraph opts
                result `shouldBeGolden` "czechHelloParagraph"

            it "renders an \"ffi\" ligature" $ do
                let opts = ParagraphOptions font Normal 8000
                let result = layoutPlain $ ligatureParagraph opts
                result `shouldBeGolden` "ligatureParagraph"

            it "breaks an \"ffi\" ligature into \"ff\" + \"i\"" $ do
                let opts = ParagraphOptions font Normal 2418
                let result = layoutPlain $ ligatureParagraph opts
                result `shouldBeGolden` "ligatureParagraphBreak1"

            it "breaks an \"ffi\" ligature into \"f\" + \"fi\"" $ do
                let opts = ParagraphOptions font Normal 1800
                let result = layoutPlain $ ligatureParagraph opts
                result `shouldBeGolden` "ligatureParagraphBreak2"

            it "handles mixed languages in LTR layout" $ do
                let opts = ParagraphOptions font Normal 8000
                let result = layoutPlain $ mixedLanguageLTRParagraph opts
                result `shouldBeGolden` "mixedLanguageLTRParagraph"

            it "handles normal line height" $ do
                let opts = ParagraphOptions font Normal 8000
                let result = layoutPlain $ trivialParagraph opts
                result `shouldBeGolden` "lineHeightNormal"

            it "handles larger line height" $ do
                let opts = ParagraphOptions font (Absolute 1600) 8000
                let result = layoutPlain $ trivialParagraph opts
                result `shouldBeGolden` "lineHeightLarger"

            it "handles smaller line height" $ do
                let opts = ParagraphOptions font (Absolute 599) 8000
                let result = layoutPlain $ trivialParagraph opts
                result `shouldBeGolden` "lineHeightSmaller"

            it "wraps mid-word when line is narrow" $ do
                let opts = ParagraphOptions font Normal 1300
                let result = layoutPlain $ czechHelloParagraph opts
                result `shouldBeGolden` "czechHelloParagraphNarrow"

            it "wraps by characters when line is ultra narrow" $ do
                let opts = ParagraphOptions font Normal 100
                let result = layoutPlain $ czechHelloParagraph opts
                result `shouldBeGolden` "czechHelloParagraphUltraNarrow"

            it "wraps lorem ipsum at 20em" $ do
                let opts = ParagraphOptions font Normal 20000
                let result = layoutPlain $ loremIpsumParagraph opts
                result `shouldBeGolden` "loremIpsum20em"

            it "wraps lorem ipsum at 100em" $ do
                let opts = ParagraphOptions font Normal 100000
                let result = layoutPlain $ loremIpsumParagraph opts
                result `shouldBeGolden` "loremIpsum100em"

            it "wraps lorem ipsum with spans at 20em" $ do
                let opts = ParagraphOptions font Normal 20000
                let result = layoutPlain $ spannedLoremIpsumParagraph opts
                result `shouldBeGolden` "spannedLoremIpsum20em"

            it "spans do not reposition lorem ipsum at 20em" $ do
                let opts = ParagraphOptions font Normal 20000
                let withoutSpans = layoutPlain $ loremIpsumParagraph opts
                let withSpans = layoutPlain $ spannedLoremIpsumParagraph opts
                paragraphRect withoutSpans `shouldBe` paragraphRect withSpans

            it "wraps mixed-script words correctly" $ do
                let opts = ParagraphOptions font Normal 6000
                let result = layoutPlain $ mixedScriptWordsParagraph opts
                result `shouldBeGolden` "mixedScriptWordsParagraph"

            it "trims spaces around lines" $ do
                let opts = ParagraphOptions font Normal 6000
                let result = layoutPlain $ manySpacesParagraph opts
                result `shouldBeGolden` "manySpacesParagraph"

            it "applies hard breaks correctly" $ do
                let opts = ParagraphOptions font Normal 5000
                let result = layoutPlain $ hardBreaksLTRParagraph opts
                result `shouldBeGolden` "hardBreaksLTRParagraph"

    describe "paginate" $ do

        describe "with Arabic font" $ do
            font <- runIO $ loadFont arabicFont 0 testingOptions

            it "wraps filler text with spans at 20em" $ do
                let
                    opts = ParagraphOptions font Normal 20000
                    pl = layoutPlain $ spannedArabicFillerParagraph opts
                    popts = PageOptions
                        { pageCurrentHeight = 1000
                        , pageNextHeight = 5000
                        , pageOrphans = 2
                        , pageWidows = 2
                        }
                    pages = paginateAll popts pl
                Pages pages `shouldBeGolden` "spannedArabicFiller20emPaginated"

        describe "with Latin font" $ do
            font <- runIO $ loadFont latinFont 0 testingOptions

            it "wraps lorem ipsum at 20em" $ do
                let
                    opts = ParagraphOptions font Normal 20000
                    pl = layoutPlain $ loremIpsumParagraph opts
                    popts = PageOptions
                        { pageCurrentHeight = 2500
                        , pageNextHeight = 8500
                        , pageOrphans = 2
                        , pageWidows = 3
                        }
                    pages = paginateAll popts pl
                Pages pages `shouldBeGolden` "loremIpsum20emPaginated"

    describe "shaped runs for demo" $ do

        describe "with Latin font" $ do
            let fontPath = latinFont
            font <- runIO $ loadFont fontPath 0 demoOptions
            let shapedRunsSpec = shapedRunsSpecWithFont fontPath font

            shapedRunsSpec "wraps lorem ipsum with spans at 20em"
                "spannedLoremIpsum20em" $
                spannedLoremIpsumParagraph $
                ParagraphOptions font Normal 300