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.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