module Data.Text.ParagraphLayoutSpec (spec) where import Data.Text.Glyphize (Font) 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 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 640